[Excel07] Μεταφορά δεδομένων από πολλά βιβλία σε ένα

[jimrenoir]

Καλησπέρα Χρόνια Πολλά Καλή Χρονιά με υγεία και χαρά για εσάς και τις Οικογένειες σας.
Ψάχνωντας στο φόρουμ βρήκα ένα θέμα ανάλογο.
http://www.ms-office.gr/forum/excel-...rgasias-2.html
Πολλά Μπράβο στον Τάσο που το έφτιαξε.Με αφορμή αυτό θα ήθελα αν είναι εύκολο για εσάς να το φτιάξετε έτσι ώστε να έχει την δυνατότητα να μεταφέρει όλα τα δεδομένα από ένα φύλλο από πολλά βιβλία έργασιας. Π.χ (Βιβλίο1 φύλλο1 ,Βιβλίο2 φύλλο1,κ.λπ.)να μεταφέρονται σε ένα καινούργιο βιβλίο εργασίας το καθένα κάτω από το άλλο.Ανεβάζω ένα παράδειγμα για να καταλάβετε τι εννοώ.(πάντα το φύλλο έχει το ίδιο όνομα).
Το έκανα με υπερσυνδέσεις αλλά επειδή τα βιβλία με τα δεδομένα είναι πάρα πολλά βαραίνει πάρα πολύ.

[Tasos]

Καλησπέρα!

Δημήτρη δοκίμασε τον παρακάτω κώδικα (όλος ο κώδικας της λειτουργικής μονάδας):

Option Explicit
Private Const MyPC = 0&
Private Const ShOptions = 65&

Function FolderBrowserDialog() As String
    Dim oShell As Object
    Dim oFolder As Object
    Set oShell = CreateObject("Shell.Application")
    Set oFolder = oShell.BrowseForFolder( _
                  Application.Hwnd, "Επιλέξτε το φάκελο με τα αρχεία προς αναζήτηση" & vbLf & _
                                    "και πατήστε 'ΟΚ'." & vbLf & _
                                    "Πατήστε 'Ακυρο'για να ακυρώσετε την ενέργεια." _
                                    & vbLf, ShOptions, MyPC)
    If Not oFolder Is Nothing Then
        FolderBrowserDialog = oFolder.Self.Path
    End If
    Set oFolder = Nothing
    Set oShell = Nothing
End Function

Sub SetFolderPath()
    Dim strPath As String
    strPath = FolderBrowserDialog
    If strPath = "" Or Left(strPath, 1) = ":" Then Exit Sub
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    Range("WBPath") = strPath
End Sub

Sub SyncValues()
    Dim wb As Workbook
    Dim wks As Worksheet
    Dim ThisWks As Worksheet
    Dim WbNamesRange As Range
    Dim SourceRange As Range
    Dim TargetRange As Range
    Dim WBPath As String
    Dim WBName As String
    Dim i As Integer
    On Error GoTo ExitHere
    Set ThisWks = ActiveSheet
    WBPath = Range("WBPath")
    If Right(WBPath, 1) <> "\" Then WBPath = WBPath & "\"
    Set WbNamesRange = Range("WBNames")
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    For i = 1 To WbNamesRange.Rows.Count
        If Trim(WbNamesRange(i).Offset(, -1).Value) = vbNullString Then
            WBName = WBPath & WbNamesRange(i).Value
            Set wb = Workbooks.Open(WBName, , True)
            Set wks = wb.Worksheets(1)
            wks.Cells.UnMerge

            Set SourceRange = wks.Range(wks.Range("A3"), wks.Range("AJM" & _
                                wks.Range("A" & wks.Rows.Count).End(xlUp).Row))
                                
            Set TargetRange = ThisWks.Range("C" & Rows.Count).End(xlUp).Offset(1) _
                              .Resize(SourceRange.Rows.Count, SourceRange.Columns.Count)
                              
            TargetRange.Value = SourceRange.Value
            wb.Saved = True
            wb.Close
            WbNamesRange(i).Offset(, -1).Value = "a"
        End If
    Next
ExitHere:
    If Err <> 0 Then
        MsgBox Err & vbLf & Err.Description
    End If
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub

Sub GetXLFiles()
    Dim fso As New Scripting.FileSystemObject, oFolder As Scripting.Folder, ofile As Scripting.File
    Dim folderPath As String
    Dim LastRow As Long
    Dim WbNamesRange As Range, fCell As Range
    folderPath = Range("WBPath").Value
    If Not fso.FolderExists(folderPath) Then
        SetFolderPath
        folderPath = Range("WBPath").Value
        If fso.FolderExists(folderPath) Then
            folderPath = Range("WBPath")
        Else
            Exit Sub
        End If
    End If
    Set oFolder = fso.GetFolder(folderPath)
    LastRow = Range("B1000").End(xlUp).Row
    Set WbNamesRange = Range("B5:B1000")
    For Each ofile In oFolder.Files
        If fso.GetExtensionName(ofile.Path) Like "xls*" Then
            Set fCell = WbNamesRange.Find(ofile.Name, LookIn:=xlValues)
            If fCell Is Nothing Then
                LastRow = LastRow + 1
                Range("B" & LastRow).Value = ofile.Name
            End If
        End If
    Next
End Sub

Τάσος

[jimrenoir]

Καλησπέρα σας ευχαριστώ για την άμεση και έγκυρη απάντηση όπως πάντα.
Έβαλα τον κώδικα και δουλεύει μιά χαρά.
Όταν κάνω την εισαγωγή των ονομάτων των βιβλίων (κουμπι εισαγωγή ονόματα βιβλίων εργασίας)και μετά πατήσω να φέρει τα δεδομένα απο το φύλλο(Stats-του κάθε βιβλίου) μόλις το τελείώσει (ΑΥΤΟ ΓΙΝΕΤΑΙ ΤΕΛΕΙΑ ΚΑΙ ΜΠΡΑΒΟ ΣΑΣ ) μου ανάβει ένα ν στην στήλη Α ότι έγινε η ενημερωση δίπλα σε κάθε βιβλίο.Εάν τώρα σβήσω το ν (οτι έγινε η ενημέρωση) σε ένα απο τα βιβλία που μπορεί να έχω αλάξει κάποια στοιχεία δεν μου το βάζει στην ίδια θέση που ήταν τα προηγούμενα δεδομένα απο το αντίστοιχο βιβλίο αλλά απο κάτω από τα άλλα δεδομένα(.Γίνεται να αντικαθιστά τα δεδομένα με τα καινούργια στην ίδια θέση που ήταν.Να σημειώσω εδώ αν βοηθάει ότι το μέγεθος των γραμμών και των στηλών δεν αλάζει.Σας ανεβάζω και παράδειγμα.)Ελπίζω να σας έδωσα να καταλάβετε τι θα ήθελα να κάνει.
Ευχαριστώ Πάρα πολύ για ότι έχετε κάνει για μένα σε αυτό το φόρουμ.Και είναι πάρα πολλά.Μακάρι να είχα και εγώ κάποιες γνώσεις για να βοήθησω άλλους απο το φόρουμ.Απλά φοβάμαι πως αν απαντήσω σε κάποιον μην τον μπερδέψω παρά τον βοήθησω.

[Tasos]

Καλησπέρα!
Δημήτρη, επισυνάπτω ένα αρχείο με κάποιες τροποποιήσεις ώστε να μπορείς να ενημερώνεις δεδομένα που ήδη έχουν εισαχθεί.

Αρχικά βάλε τα δεδομένα σου με το γνωστό τρόπο.

Στη στήλη Α θα συμπληρωθεί ένας μοναδικός αριθμός (ID) που θα χρησιμεύσει για τον εντοπισμό των γραμμών την επόμενη φορά που θα θελήσεις να ενημερώσεις τα δεδομένα.

Στη στήλη Β θα συμπληρωθεί η ημερομηνία και ώρα της τελευταίας ενημέρωσης.

Στη στήλη D θα δημιουργηθεί ένας σύνδεσμος. Κάνοντας κλικ επάνω του θα ενημερωθούν οι γραμμές που έχουν το αντίστοιχο ID.

Το αρχείο αυτό είναι παραδειγματικό. Μελέτησε τον κώδικα και κάνε τις αλλαγές που ίσως χρειαστούν.

Τάσος

[jimrenoir]

Καλημέρα σας. Το αρχείο δουλεύει άψογα σας ευχαριστώ πάρα πολύ.Με γλιτώσατε από αρκετές ώρες κάθε φορά επικόλησης.Ευχαριστώ ολόθερμα

[xristos]

Φίλοι του φόρουμ γειά σας.
Ψάχνοντας στο φόρουμ είδα αυτό το πρόγραμμα
το οποίο θα με ενδιέφερε.
Φίλε Τάσο δημιουργέ του προγράμματος
έκανα όλα αυτά που έγραφες
αλλά δεν ήρθαν τα δεδομένα που ήθελα
και μου έβγαλε το μήνυμα που σου επισυνάπτω
όπως και τα έγγραφα απ' όπου θέλω να πάρω τα δεδομένα
Θέλω να πάρω στοιχεία από τις στήλες
A4, B4, N4, V4, I4, R4, S4, T4
Θέλω να έρθουν όλα τα δεδομένα που είναι αρκετά (ακόμα και 3,500 στοιχεία από κάποιο βιβλίο)
που με τα χρόνια θα ανεβαίνουν τα στοιχεία)
Τι κάνω λάθος;;;;