Datensätze aus mehreren Tabellen in einer Tabelle Zusammenfassen.

  • Excel

Es gibt 7 Antworten in diesem Thema. Der letzte Beitrag () ist von S.newman.

    Datensätze aus mehreren Tabellen in einer Tabelle Zusammenfassen.

    Hallo liebe Profis,

    Ich bin leider noch ein ziemlicher Anfänger in VBA, daher sucher ich hier Hilfe. Ich versuche einen Makro zu schreiben, mit dessen Hilfe ich Daten von verschiedenen Excel Datein in einer zusammenfassen kann. Die Blätter sind alle gleich aufgebaut und die gewünschten Daten immer in den selben Zellen. Leider sind diese Zellen weder in einer/m Spalte, Zeile, Feld sondern wild verteilt:(C15,C16,C17,C34,C41,C49,C50,C56,C57,C133,C139,C145,F145,D152,C159,C161,C162) im Sheet("Overview").

    Es sind Cirka 50 Excel Datein im selben Ordner,es kommen aber immer mal welche hinzu, den ich gerne automatisch durchsuchen würde. Ich will also eine Datei Öffnen, die Daten auslesen und in einen Array (50, 18) stecken (50 Daten und 17 Werte plus der Dateiname an Stelle (i,1)). Dannach soll die Datei geschlossen werden und die nächste geöffnet werden und in die nächste Zeile des Arrays schreiben. am Ende soll der Ganze Arry in die Übersicht eingefügt werden.
    Schön Wär auch wenn man den Arry Dynamisch machen könnte so das er sich an die aktuelle Dateien anzahl anpasst.

    Die Tabelle soll dann quasi so ausschauen.

    Dateiname
    Wert1
    Wert n
    Wert 17
    Tab 1



    Tab n



    Tab 50







    Quellcode

    1. Sub Uebersicht_erstellen()
    2. Dim dat
    3. Dim ordner
    4. Dim datein
    5. Dim fso
    6. Dim L As Integer
    7. Dim i
    8. Dim Arr(100, 25) As Integer
    9. Set dat = Application.FileDialog(msoFileDialogFolderPicker)
    10. With dat
    11. .Title = "Welche Daten wollen sie zusammenfassen?"
    12. .InitialFileName = "C:/nocheinorner/und_nocheiner" 'oder was auch immer
    13. nochmal:
    14. If .Show = -1 Then
    15. ordner = .SelectedItems(1)
    16. Else:
    17. If MsgBox(" Ordner wählen ! " & vbCrLf & "Nochmal ?", vbYesNo) = vbYes Then
    18. GoTo nochmal
    19. Else:
    20. GoTo raus
    21. End If
    22. End If
    23. End With
    24. Set fso = CreateObject("Scripting.filesystemobject")
    25. Set datein = fso.getfolder(ordner)
    26. For Each i In datein.Files
    27. If i.Name Like "*.xlsx" Then
    28. Dim Arry(100, 25)
    29. Workbooks.Open WB
    30. Sheets("Overview").Select
    31. Arr(L, 0) = C15
    32. Arr(L, 1) = C16
    33. Arr(L, 2) = B17 ' Bis Arr(L, 16) ?
    34. L = L + 1
    35. Workbooks(WB.Name).Close False
    36. End If
    37. Next
    38. Range("B:U") = Arr
    39. raus:
    40. End Sub


    Ich habe anhand meiner rudimentären Kenntnise und einiger Codefetzen schonmal ein Frankencode geschriebn, welcher aber nicht so recht möchte. Würde mich freuen wenn mir jemand helfen könnte :)

    Grüße Newman

    S.newman schrieb:

    For Each i In datein.Files
    If i.Name Like "*.xlsx" Then
    '...
    Next
    der in diesem Block enthaltene Code ist etwas grausam


    Visual Basic-Quellcode

    1. Dim ExcelFile As Object, wb as Workbook, MyArray as Variant
    2. For Each ExcelFile In datein.Files
    3. If ExcelFile.Name Like "*.xlsx" Then
    4. Set wb=Workbooks.Open(ExcelFile.Path)
    5. MyArray = wb.Sheets("Overview".Range("C15,C16,C17,C34,C41,C49,C50,C56,C57,C133,C139,C145,F145,D152,C159,C161,C162").Value
    6. wb.Close False
    7. r= Cells(Rows.Count,1).End(xlUp).Row+1
    8. Cells(r,1) = ExcelFile.Name
    9. Range(Cells(r,2), Cells(r,ubound(MyArray)+2)).Value = MyArray
    10. Next

    Du brauchst nicht übrigens zwangsläufig über ein Array gehen, du kannst auch einfach mit Range.Copy von einem ins andere Sheet kopieren
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --
    Ich danke dir für deine Hilfe habe den Code jetzt dahingehend verändert.

    Quellcode

    1. Dim ordner
    2. Dim datein
    3. Dim fso
    4. Dim L As Integer
    5. Dim i
    6. Dim Arr(100, 25) As Integer
    7. Set dat = Application.FileDialog(msoFileDialogFolderPicker)
    8. With dat
    9. .Title = "Welche Daten wollen sie zusammenfassen?"
    10. .InitialFileName = "C//" 'oder was auch immer
    11. nochmal:
    12. If .Show = -1 Then
    13. ordner = .SelectedItems(1)
    14. Else:
    15. If MsgBox(" Ordner wählen ! " & vbCrLf & "Nochmal ?", vbYesNo) = vbYes Then
    16. GoTo nochmal
    17. Else:
    18. GoTo raus
    19. End If
    20. End If
    21. End With
    22. Set fso = CreateObject("Scripting.filesystemobject")
    23. Set datein = fso.getfolder(ordner)
    24. Dim ExcelFile As Object
    25. Dim wb As Workbook
    26. Dim MyArray As Variant
    27. For Each ExcelFile In datein.Files
    28. If ExcelFile.Name Like "*.xlsx" Then
    29. Set wb = Workbooks.Open(ExcelFile.Path)
    30. MyArray = wb.Sheets("Results Overview").Range("C15,C16,C17,C34,C41,C49,C50,C56,C57,C133,C139,C145,F145,D152,C159,C161,C162").Value
    31. wb.Close False
    32. r = Cells(Rows.Count, 1).End(xlUp).Row + 1
    33. Cells(r, 1) = ExcelFile.Name
    34. Range(Cells(r, 2), Cells(r, UBound(MyArray) + 2)).Value = MyArray
    35. End If
    36. Next
    37. Range("B:U") = MyArray
    38. raus:
    39. End Sub


    Ich bekomme die Fehlermeldung:
    "Laufzeitfehler 13 Typen unverträglich" Weißt du was das vielleicht bedeutet?
    [Range(Cells(r, 2), Cells(r, UBound(MyArray) + 2)).Value = MyArray]

    Dieser Beitrag wurde bereits 2 mal editiert, zuletzt von „S.newman“ ()

    Sieht wohl so aus, dass er nur die erste Zelle in das Array nimmt.
    Mach's ohne Array und kopiere direkt aus dem Range

    Visual Basic-Quellcode

    1. Dim ExcelFile as Object, wb as Workbook, CopyRange As Range, cell As Range, r As Long, c As Integer
    2. '...
    3. ​For Each ExcelFile In datein.Files
    4. If ExcelFile.Name Like "*.xlsx" Then
    5. Set wb = Workbooks.Open(ExcelFile.Path)
    6. Set CopyRange = wb.Sheets("Results Overview").Range("C15,C16,C17,C34,C41,C49,C50,C56,C57,C133,C139,C145,F145,D152,C159,C161,C162")
    7. r = Cells(Rows.Count, 1).End(xlUp).Row + 1
    8. Cells(r, 1) = ExcelFile.Name
    9. c = 2
    10. For Each cell In CopyRange
    11. Cells(r, c).Value = cell.Value
    12. c = c + 1
    13. Next
    14. wb.Close False
    15. End If
    16. Next
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --
    Danke für die schnelle Hilfe.

    Sorry, das ich nerve, aber nun bekomme ich einen neuen Laufzeitfehler 1004 (Anwendungs oder objektbezogener Fehler.
    [Set CopyRange = wb.Sheets("Results Overview").Range("C15,C16,C17,C34,C41,C49,C50,C56,C57,C133,C139,C145,F145,D152,C159,C161,C162")]
    Danke dir, war wirklich kein fehler. Hab Die Datei mit Makro nochmal neu gestartet und jetzt läuft er druch. Allerdings gibt er die werte nicht in die Tabelle aus. Habe ich irgend etwas vergessen ?

    Quellcode

    1. Sub Uebersicht_erstellen()
    2. Dim dat
    3. Dim ordner
    4. Dim datein
    5. Dim fso
    6. With Application
    7. dsplalert = .DisplayAlerts
    8. cal = .Calculation
    9. scrup = .ScreenUpdating
    10. ev = .EnableEvents
    11. .DisplayAlerts = False
    12. .Calculation = xlCalculationManual
    13. .ScreenUpdating = False
    14. .EnableEvents = False
    15. .AskToUpdateLinks = False
    16. End With
    17. Set dat = Application.FileDialog(msoFileDialogFolderPicker)
    18. With dat
    19. .Title = "Welche Daten wollen sie zusammenfassen?"
    20. .InitialFileName = "C/" 'oder was auch immer
    21. nochmal:
    22. If .Show = -1 Then
    23. ordner = .SelectedItems(1)
    24. Else:
    25. If MsgBox(" Ordner wählen ! " & vbCrLf & "Nochmal ?", vbYesNo) = vbYes Then
    26. GoTo nochmal
    27. Else:
    28. GoTo raus
    29. End If
    30. End If
    31. End With
    32. Set fso = CreateObject("Scripting.filesystemobject")
    33. Set datein = fso.getfolder(ordner)
    34. Dim ExcelFile As Object, wb As Workbook, CopyRange As Range, cell As Range, r As Long, c As Integer
    35. '...
    36. For Each ExcelFile In datein.Files
    37. If ExcelFile.Name Like "*.xlsx" Then
    38. Set wb = Workbooks.Open(ExcelFile.Path)
    39. Set CopyRange = wb.Sheets("Results Overview").Range("C15,C16,C17,C34,C41,C49,C50,C56,C57,C133,C139,C145,F145,D152,C159,C161,C162")
    40. r = Cells(Rows.Count, 1).End(xlUp).Row + 1
    41. Cells(r, 1) = ExcelFile.Name
    42. c = 2
    43. For Each cell In CopyRange
    44. Cells(r, c).Value = cell.Value
    45. c = c + 1
    46. Next
    47. wb.Close False
    48. End If
    49. Next
    50. raus:
    51. With Application
    52. .DisplayAlerts = dsplalert
    53. .Calculation = cal
    54. .ScreenUpdating = scrup
    55. .EnableEvents = ev
    56. .AskToUpdateLinks = True
    57. End With
    58. End Sub


    Also er öffnet alle sheets aber die "Sammelmappe" blebt leer.