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

Forum (https://www.ms-office.gr/forum/)

- Excel - Ερωτήσεις / Απαντήσεις (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/)

- - [Excel07] Μεταφορά δεδομένων από πολλά βιβλία σε ένα (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/2912-metafora-dedomenon-apo-polla-biblia-se-ena.html)

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

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

Καλησπέρα!

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

Κώδικας:

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

Τάσος

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

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

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

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

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

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

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

Τάσος

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

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