Sub gutschriftenZusammen()
'In das Tabellenblatt Dateinamen gehen
Worksheets("Dateinamen").Activate
'Definieren einer String in der, der Dateipfad eingelesen wird
Dim Ordnerpfad As String
'Auswaehlen des Ordners um Dateipfad zu ermitteln
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Bitte wähle den Ordner in dem sich die Gutschriften befinden"
.InitialFileName = ""
.InitialView = msoFileDialogViewThumbnail
.ButtonName = "Auswählen"
If .Show = -1 Then
Ordnerpfad = .SelectedItems(1)
End If
End With
'Zelle auswaehlen, um Liste einzufügen und Aktivieren des richtigen Tabellenblattes
Worksheets("Dateinamen").Activate
Range("A1").Select
'Fuegt Liste des ausgewaehlten Ordners ein
Dim xRow As Long
Dim xDirect$, xFname$, InitialFoldr$
InitialFoldr$ = "C:\"
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Bitte wähle den Ordner in dem sich die Gutschriften befinden"
.InitialFileName = InitialFoldr$
.Show
If .SelectedItems.Count <> 0 Then
xDirect$ = .SelectedItems(1) & "\"
xFname$ = Dir(xDirect$, 7)
Do While xFname$ <> ""
ActiveCell.Offset(xRow) = xFname$
xRow = xRow + 1
xFname$ = Dir
Loop
End If
End With
'Es wird die letzte Zeile und die letzte Spalte im Tabellenblatt ermittelt und alles markiert
'Letzte Reihe mit einem Wert
Dim letzteZeile As Integer
letzteZeile = ThisWorkbook.Sheets("Dateinamen").Cells(Rows.Count, 1).End(xlUp).Row
'Letzte Spalte mit einem Wert
Dim letzteSpalte As Integer
letzteSpalte = ThisWorkbook.Sheets("Dateinamen").Cells(1, Columns.Count).End(xlToLeft).Column
'Markieren
Range(Cells(1, 1), Cells(letzteZeile, letzteSpalte)).Select
'Vorbereiten der While-Schleife
Dim DateienZeile As Integer
DateienZeile = 1
'Öffnet so viele Dateien wie Dateinamen (Zeilen) in der Liste sind. Anhand der Dateinamen die in der Liste stehen
'SCHLEIFE
While DateienZeile <> letzteZeile + 1
Worksheets("Dateinamen").Select
Dim DateiName As String
Dim Dateipfad As String
DateiName = Cells(DateienZeile, 1).Value
Dateipfad = Ordnerpfad + "\" + DateiName
' MsgBox Dateipfad
'Öffnen der Datei
Workbooks.Open Dateipfad, Local:=True
'Ermitteln der letzten Spalte und der letzten Zeile der geoeffneten Datei
Dim letzteZeileSchleife As Integer
letzteZeileSchleife = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
letzteZeileSchleife = letzteZeileSchleife - 1
Dim letzteSpalteSchleife As Integer
letzteSpalteSchleife = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Dim letzteZeileDatenGutschrift As Integer
'Kopieren des gesamten Inhalts der Datei, falls bei Daten Gutschrift kein Inhalt zunfinden ist. Falls Inhalt vorhanden erden die Daten ab Zeile 2 kopiert (ohne Kopfzeile)
If letzteZeileDatenGutschrift < 1 Then
Range(Cells(1, 1), Cells(letzteZeileSchleife, letzteSpalteSchleife)).Copy
'########################################
Workbooks("Beta.xlsm").Activate
Worksheets("Daten Gutschrift").Select
'########################################
letzteZeileDatenGutschrift = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Range(Cells(1, 1), Cells(1, 1)).Select
Else
Range(Cells(2, 1), Cells(letzteZeileSchleife, letzteSpalteSchleife)).Copy
'########################################
Workbooks("Beta.xlsm").Activate
Worksheets("Daten Gutschrift").Select
'########################################
letzteZeileDatenGutschrift = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Range(Cells(letzteZeileDatenGutschrift + 1, 1), Cells(letzteZeileDatenGutschrift + 1, 1)).Select
End If
'Einfügen des kopierten Inhalts. Danach schließen der Datei aus der kopiert wurde.
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Workbooks(DateiName).Close SaveChanges:=False
Worksheets("Dateinamen").Select
DateienZeile = DateienZeile + 1
Wend
End Sub
|