Private Sub CommandButton1_Click()
Dim arrZusammen As Variant
Dim lngLetzte As Long
Dim lngDatei As Long
Dim d As Long
Dim t As Long
Dim lngLetzteQ As Long
Dim lngLetzteZ As Long
Dim lngZeile As Long
Dim strBlattE As String
Dim strBlattZ As String
Dim strQuelldatei As String
Dim strQuellpfad As String
Dim strZieldatei As String
Dim strZielpfad As String
Dim strPfad As String
Dim strPWZD As String
Dim strPWZT As String
'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False
'Namen der Arbeitbl?tter in den Tabellen festlegen - Namen anpassen
strBlattE = "Salary Increase 2019"
strBlattZ = "Salary increase History"
With ActiveSheet
'letzte beschriebene Zeile im aktiven Tabellenblatt ermitteln
lngLetzte = .Cells(Rows.Count, 1).End(xlUp).Row
'Daten der zusammenzufassenden Dateien in Array einlesen
arrZusammen = .Range(.Cells(3, 1), .Cells(lngLetzte, 9))
End With
'eingelesenes Array durchlaufen
For d = LBound(arrZusammen, 1) To UBound(arrZusammen, 1)
'zu ?ffnende Datei und Pfad einlesen
strQuelldatei = arrZusammen(d, 4) & ".xlsx" 'Endung f?r Excel-Datei erg?nzen
strQuellpfad = arrZusammen(d, 5)
If Right(strQuellpfad, 1) <> "\" Then strQuellpfad = strQuellpfad & "\" 'Pr?fen ob Pfad mit \ endet, ansonsten erg?nzen
strPWQD = arrZusammen(d, 2) 'Passwort f?r das ?ffnen der Datei
strPWQT = arrZusammen(d, 3) 'Passwort f?r die einzelnen Arbeitsbl?tter
'pr?fen, ob neue Datei angelegt werden muss
'dazu Dateinummer aus Array mit Variable f?r Dateinummer vergleichen
If lngDatei <> arrZusammen(d, 1) Then
'falls es nicht der erste Durchlauf ist, dann erfolgt hier die Endverarbeitung und das Schlie?en der zusammengefassten Datei
If lngDatei > 0 Then
With Workbooks(strZieldatei)
'1. Arbeitsblatt bearbeiten
'in Spalte J die Formeln neu schreiben
With .Worksheets(strBlattE)
lngLetzte = .Cells(Rows.Count, 1).End(xlUp).Row
For lngZeile = 11 To lngLetzte - 1
.Cells(lngZeile, 10).Formula = "=I" & lngZeile & "/39"
Next lngZeile
End With
'pr?fen, ob Arbeitsbl?tter gesch?tzt werden sollen
If strPWZT <> "" Then
For t = 1 To .Worksheets.Count
.Worksheets(t).Protect strPWZT
Next t
End If
'Arbeitsmappe schlie?en
.Close (True)
End With
End If
'Variable f?r die Nummer der neuen Datei anpassen
lngDatei = arrZusammen(d, 1)
'nun die neue Zieldatei anlegen
'dazu erst einmal die notwendigen Daten einlesen
strZieldatei = arrZusammen(d, 8) & ".xlsx" 'neuer Name der Zieldatei einlesen und Endung erg?nzen
strZielpfad = arrZusammen(d, 9) 'Zielpfad einlesen
If Right(strZielpfad, 1) <> "\" Then strZielpfad = strZielpfad & "\" 'Pr?fen ob Pfad mit \ endet, ansonsten erg?nzen
strPWZD = arrZusammen(d, 6) 'Passwort f?r ?ffnen der neuen Datein
strPWZT = arrZusammen(d, 7) 'Passwort f?r den Schutz der Tabellenbl?tter in der neuen Datei
'erste Datei ?ffnen
If arrZusammen(d, 2) <> "" Then
Workbooks.Open Filename:=strQuellpfad & strQuelldatei, Password:=arrZusammen(d, 2)
Else
Workbooks.Open Filename:=strQuellpfad & strQuelldatei
End If
'ggf. vorhandenen Passwortschutz in den einzelnen Tabellenbl?ttern entfernen
With ActiveWorkbook
For t = 1 To .Worksheets.Count
If .Worksheets(t).ProtectContents = True Then
If arrZusammen(d, 3) <> "" Then
Worksheets(t).Unprotect arrZusammen(d, 3)
Else
Worksheets(t).Unprotect
End If
End If
Next t
'Datei unter neuem Namen speichern
'Pr?fen, ob der neue Pfad existiert, ansonsten anlegen
If Dir(strZielpfad, vbDirectory) = "" Then MakeDir (strZielpfad)
'dann Datei speichern
.SaveAs Filename:=strZielpfad & strZieldatei, Password:=strPWZD
End With
Else
'Quelldatei ?ffnen
If arrZusammen(d, 2) <> "" Then
Workbooks.Open Filename:=strQuellpfad & strQuelldatei, Password:=arrZusammen(d, 2)
Else
Workbooks.Open Filename:=strQuellpfad & strQuelldatei
End If
'ggf. vorhandenen Passwortschutz in den einzelnen Tabellenbl?ttern entfernen
With ActiveWorkbook
For t = 1 To .Worksheets.Count
If .Worksheets(t).ProtectContents = True Then
If arrZusammen(d, 3) <> "" Then
Worksheets(t).Unprotect arrZusammen(d, 3)
Else
Worksheets(t).Unprotect
End If
End If
Next t
'Daten aus dem 1.Blatt kopieren und in Zieltabelle einf?gen
With .Worksheets(strBlattE)
'letzte Zeile im 1. Arbeitsblatt der Tabelle ermitteln
lngLetzteQ = .Cells(Rows.Count, 1).End(xlUp).Row
'Einf?gezeile im 1. Tabellenblatt der Zieldatei ermitteln
lngLetzteZ = Workbooks(strZieldatei).Worksheets(strBlattE).Cells(Rows.Count, 1).End(xlUp).Row
'leere Zeilen in Zieldatei einf?gen
Workbooks(strZieldatei).Worksheets(strBlattE).Rows(lngLetzteZ & ":" & lngLetzteZ + lngLetzteQ - 12).Insert Shift:=xlDown
'ab Zeile 11 kopieren, ohne Summenzeile
.Range(.Cells(11, 1), .Cells(lngLetzteQ - 1, 38)).Copy Destination:=Workbooks(strZieldatei).Worksheets(strBlattE).Cells(lngLetzteZ, 1)
End With
Application.CutCopyMode = False 'Auswahl aufheben
'nun f?r das zweite Tabellenblatt
'Einf?gezeile im 2. Tabellenblatt der Zieldatei ermitteln
lngLetzteZ = Workbooks(strZieldatei).Worksheets(strBlattZ).Cells(Rows.Count, 1).End(xlUp).Row
'Daten aus dem 2.Blatt kopieren und in Zieltabelle einf?gen
With .Worksheets(strBlattZ)
'letzte Zeile im 1. Arbeitsblatt der Tabelle ermitteln
lngLetzteQ = .Cells(Rows.Count, 1).End(xlUp).Row
'leere Zeilen in Zieldatei einf?gen
Workbooks(strZieldatei).Worksheets(strBlattZ).Rows(lngLetzteZ & ":" & lngLetzteZ + lngLetzteQ - 18).Insert Shift:=xlDown
'ab Zeile 17 kopieren
.Range(.Cells(17, 1), .Cells(lngLetzteQ - 1, 31)).Copy Destination:=Workbooks(strZieldatei).Worksheets(strBlattZ).Cells(lngLetzteZ, 1)
End With
Application.CutCopyMode = False 'Auswahl aufheben
'ge?ffnete Datei wieder schlie?en, ohne Speicherung
.Close (False)
End With
End If
Next d
'letzte neu zusammengestellte Datei schlie?en
With Workbooks(strZieldatei)
'1. Arbeitsblatt bearbeiten
'in Spalte J die Formeln neu schreiben
With .Worksheets(strBlattE)
lngLetzte = .Cells(Rows.Count, 1).End(xlUp).Row
For lngZeile = 11 To lngLetzte - 1
.Cells(lngZeile, 10).Formula = "=I" & lngZeile & ",TODAY(),""Y"")"
.Cells(lngZeile, 16).Formula = "=O" & lngZeile & "/39"
.Cells(lngZeile, 18).Formula = "=IF(Q" & lngZeile & "="""","""",IF(N" & lngZeile & "=""Yes"",Q" & lngZeile & "*13.25,Q" & lngZeile & "*12))"
.Cells(lngZeile, 20).Formula = "=IF(S" & lngZeile & "="""","""",IF(N" & lngZeile & "=""Yes"",S" & lngZeile & "*13.25,S" & lngZeile & "*12))"
.Cells(lngZeile, 21).Formula = "=IF(O" & lngZeile & "<39,(S" & lngZeile & "O" & lngZeile & ")*39),"""")"
.Cells(lngZeile, 22).Formula = "=IF(U" & lngZeile & "="""","""",IF(N" & lngZeile & "=""Yes"",U" & lngZeile & "*13.25,U" & lngZeile & "*12))"
.Cells(lngZeile, 24).Formula = "=IF(W" & lngZeile & "=""No"",Q" & lngZeile & ",Q" & lngZeile & "*1.025)"
.Cells(lngZeile, 25).Formula = "=IF(X" & lngZeile & "="""","""",IF(N" & lngZeile & "=""Yes"",X" & lngZeile & "*13.25,X" & lngZeile & "*12))"
.Cells(lngZeile, 26).Formula = "=IF(W" & lngZeile & "=""No"",S" & lngZeile & ",S" & lngZeile & "*1.025)"
.Cells(lngZeile, 27).Formula = "=IF(Z" & lngZeile & "="""","""",IF(N" & lngZeile & "=""Yes"",Z" & lngZeile & "*13.25,Z" & lngZeile & "*12))"
.Cells(lngZeile, 33).Formula = "=IF(COUNTA(AD" & lngZeile & ":AE" & lngZeile & "),IF(ISERROR(IF(COUNTA(AE" & lngZeile & "),AE" & lngZeile & ",SUM(AI" & lngZeile & "-S" & lngZeile & "/S" & lngZeile & ")),IF(COUNTA(AE" & lngZeile & "),SUM(AI" & lngZeile & "-S" & lngZeile & ")/S" & lngZeile & ")),"""")"
.Cells(lngZeile, 34).Formula = "=IF(ISERROR(AI" & lngZeile & "-S" & lngZeile & "),0,AI" & lngZeile & "-S" & lngZeile & ")"
.Cells(lngZeile, 35).Formula = "=IF(COUNTA(AD" & lngZeile & ":AE" & lngZeile & "),IF(COUNTA(AD" & lngZeile & "),AD" & lngZeile & "),IF(COUNTA(AE" & lngZeile & "),S" & lngZeile & "*AE" & lngZeile & "+S" & lngZeile & ",Z" & lngZeile & ")),"""")"
.Cells(lngZeile, 36).Formula = "=IF(AI" & lngZeile & "="""","""",IF(N" & lngZeile & "=""Yes"",AI" & lngZeile & "*13.25,AI" & lngZeile & "*12))"
.Cells(lngZeile, 37).Formula = "=IF(AC" & lngZeile & "=""No"",1,IF(AD" & lngZeile & "="""","""",1))"
.Cells(lngZeile, 38).Formula = "=IF(AC" & lngZeile & "=""No"",1,IF(AE" & lngZeile & "="""","""",1))"
Next lngZeile
End With
'pr?fen, ob Arbeitsbl?tter gesch?tzt werden sollen
If strPWZT <> "" Then
For t = 1 To .Worksheets.Count
.Worksheets(t).Protect strPWZT
Next t
End If
'Arbeitsmappe schlie?en
.Close (True)
End With
'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True
'Abschlussmeldung
MsgBox "Es wurden alle Dateien erstellt!", 64, "Hinweis"
End Sub