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").
Im Prinzip soll es so ablaufen: Ich wähle einen Ornder aus (Klappt), das Programm öffnet eine Datei und kopiert die Daten, schließt die Datei. Fügt die Daten in die Zusammenfassende Tabelle ein. öffnet die nächste usw... insgesamt sind es ca 30 Dateien, wo aber ständig was dazukommt, neue Dteien im ordner sollen also beim nächsten ausführen mituntersucht werden.
Dashier habe ich durch Recherche und den Recorder bisher zusammengeschreiebn.
Sub Uebersicht_erstellen()
Dim dat
Dim ordner
Dim datein
Dim fso
With Application
dsplalert = .DisplayAlerts
cal = .Calculation
scrup = .ScreenUpdating
ev = .EnableEvents
.DisplayAlerts = False
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
.AskToUpdateLinks = False
End With
Set dat = Application.FileDialog(msoFileDialogFolderPicker)
With dat
.Title = "Welche Daten wollen sie zusammenfassen?"
.InitialFileName = "C/" 'oder was auch immer
nochmal:
If .Show = -1 Then
ordner = .SelectedItems(1)
Else:
If MsgBox(" Ordner wählen ! " & vbCrLf & "Nochmal ?", vbYesNo) = vbYes Then
GoTo nochmal
Else:
GoTo raus
End If
End If
End With
Set fso = CreateObject("Scripting.filesystemobject")
Set datein = fso.getfolder(ordner)
Dim ExcelFile As Object, wb As Workbook, CopyRange As Range, cell As Range, r As Long, c As _
Integer
For Each ExcelFile In datein.Files
If ExcelFile.Name Like "*.xlsx" Then
Set wb = Workbooks.Open(ExcelFile.Path)
Set CopyRange = wb.Sheets("Results Overview").Range("C15,C16,C17,C34,C41,C49,C50,C56,C57, _
C133,C139,C145,F145,D152,C159,C161,C162")
r = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(r, 1) = ExcelFile.Name
c = 2
For Each cell In CopyRange
Cells(r, c).Value = cell.Value
c = c + 1
Next
wb.Close False
End If
Next
raus:
With Application
.DisplayAlerts = dsplalert
.Calculation = cal
.ScreenUpdating = scrup
.EnableEvents = ev
.AskToUpdateLinks = True
End With
End Sub
Öffnen tut es alle dateien im richtigen Ordner. Nur erscheinen keine Daten in der Tabelle.
Würde mich über eure Hilfe sehr Freuen.
Beste Grüße!