302 Aufrufe
Gefragt in Tabellenkalkulation von marc1984 Einsteiger_in (51 Punkte)

Hallo M.O.

Du hast für mich eine Liste in VBA programmiert (siehe Anhang) mit der man eine Masterliste aufsplitten kann.

Ehrlich schäme ich mich diesen Beitrag gerade zu erstellen, da es mir ein wenig frech rüber kommt blush

Gäbe es die Möglichkeit einer Umkehrprogrammierung, d.h. mit dem man die Listen wieder in eine zusammenführt?

Ich habe hierfür ein Tabellenblatt mit dem Namen "Zusammenführen..." hinzugenommen, die zeigt das ungefähre Bild (das ist nur ein Layout).

http://supportnet.de/forum/?qa=blob&qa_blobid=13804683647180346966

LG Marc

5 Antworten

0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)
Bearbeitet von m-o

Hallo Marc,

wie war das mit dem kleinen Finger und der ganzen Hand???wink

Ich nehme mal an, dass es in den einzelnen Datei zwei Tabellenblätter gibt und die Daten inklusive der Formeln jeweils untereinander in die neue Datei gespeichert werden sollen und auch wieder mit einem Passwort versehen werden sollen (falls eines in den Spalten F und G steht? Und in der letzten Zeile der Blätter, die zusammengeführt werden sollen, ist das Ergebnis?

Gruß

M.O.

0 Punkte
Beantwortet von marc1984 Einsteiger_in (51 Punkte)

Hallo M.O.,

genau so ist es blush - also mit Deiner Erläuterung.

Jep mit der Hand, da war mal was laugh

Dein Makro funktioniert so suuuuuuuuper. Ich denke es werden sich einige aus unseren anderen Abteilungen hier im Forum melden, nachdem ich gesagt habe woher das Makro kommt blush

LG Marc

0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)

Hallo Marc,

das folgende Makro gehört in das VBA-Projekt der Tabelle "Zusammenführen" (für deinen Button "Los"):

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 = "Blatt 1"
strBlattZ = "Blatt 2"

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, 13)).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, 13)).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 & "/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
    
'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True
        
'Abschlussmeldung
MsgBox "Es wurden alle Dateien erstellt!", 64, "Hinweis"
        
End Sub

Damit das Makro funktioniert, muss noch der folgende Code in ein Modul der Arbeitsmappe eingefügt werden:

Public Function MakeDir(ByVal Ordnerpfad As String)
 
   ' Late Binding, kein Verweis auf "Microsoft Scripting Runtime" notwendig
   ' Quelle: http://www.dbwiki.net/
   ' Mit dieser Funktion kann ein neuer Pfad auch mit mehreren neuen Unterverzeichnissen angelegt werden
     
   Dim objFso As Object 'FileSystemObject
 
   Set objFso = CreateObject("Scripting.FileSystemObject")
 
   If Not objFso.FolderExists(Ordnerpfad) Then
      MakeDir objFso.GetParentFolderName(Ordnerpfad)
      objFso.createFolder Ordnerpfad
   End If
 
End Function

Probiere mal aus, ob das alles so klappt, wie ihr euch das vorstellt.

Gruß

M.O.

0 Punkte
Beantwortet von marc1984 Einsteiger_in (51 Punkte)
Hallo M.O.,

erst einmal vielen vielen lieben Dank für Deine Mühen.

Ich war die letzten Wochen krankheitsbedingt nicht online - weshalb ich mich erst heute melden kann.

Ich habe heute Dein Makro etwas ergänzt (Formeln und Spaltenanzahl) und bekomme nun folgende Fehlermeldung: Index außerhalb des gültigen Bereichs...

Lieben Dank nochmal.

Das Makro:
0 Punkte
Beantwortet von marc1984 Einsteiger_in (51 Punkte)
Bearbeitet von halfstone
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
...