34 Aufrufe
Gefragt in Tabellenkalkulation von marc1984 Einsteiger_in (37 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

3 Antworten

0 Punkte
Beantwortet von m-o Profi (15.2k 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 (37 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 (15.2k 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.

...