Office: (Office 2016) Excel VBA - Zellinhalte anhand von Spaltenüberschriften finden und kopieren

Hi zusammen,

Ihr konntet mir bisher immer so super helfen, da setze ich schwer auf euren erneuten support :-)

Folgende Situation:
Ich habe eine Arbeitsmappe(Beispiel beigefügt) mit mehreren Tabellenblättern.
Die Tabellenblätter (ProduktA,ProduktB,ProduktC) sind alle exakt gleich aufgebaut.
Die Anzahl der Zeilen variiert allerdings.
Jetzt möchte ich nur bestimmte Infos in einem neuen Tabellenblatt (Abgänge) zusammenfassen.
Bisher habe ich mit unten stehendem Code gearbeitet:
Also immer für jedes einzelne Tabellenblatt nen Haufen code geschrieben.
Abgesehen davon, dass es hier drin auch einen kleinen Fehler gibt, den ich in der Originaldatei schon behoben habe. Gibt es in der Originaldatei allerdings auch noch wesentlich mehr Tabellenblätter die zusammengefasst werden müssten.

Jetzt meine Frage: Das geht doch sicher schlanker.
So nach dem Motto "Suche mir die Spaltenüberschrift und werfe mir alle dazugehörigen Zeilen aus den Tabellenblättern in das Tabellenblatt "Abgänge" .

Danke schon mal für eure Hilfe und Tipps.

VG
Charlotte

Code:

Option Explicit

Sub Abgaengeermitteln()

Application.ScreenUpdating = False

Dim i As Long
Dim j As Long
j = 2
Dim WbAct       As Workbook 'Diese Arbeitsmappe
Set WbAct = ThisWorkbook

'ProduktA
With WbAct.Sheets("ProduktA") 'Artikelnummer Übertragen
     For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
       .Range(.Cells(i, 1), .Cells(i, 1)).Copy Destination:=Sheets("Abgänge").Cells(j, 1)
           j = j + 1
    Next i
    j = 2
    For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row 'Anzahl übertragen
       .Range(.Cells(i, 2), .Cells(i, 2)).Copy Destination:=Sheets("Abgänge").Cells(j, 2)
       j = j + 1
     
    Next i
    j = 2
 
    For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row 'Käufer übertragen
       .Range(.Cells(i, 5), .Cells(i, 5)).Copy Destination:=Sheets("Abgänge").Cells(j, 3)
          j = j + 1
    Next i
   
    End With
   
 'ProduktB
   With WbAct.Sheets("ProduktB") 'Artikelnummer Übertragen
     For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
       .Range(.Cells(i, 1), .Cells(i, 1)).Copy Destination:=Sheets("Abgänge").Cells(j, 1)
           j = j + 1
    Next i
    j = 2
    For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row 'Anzahl übertragen
       .Range(.Cells(i, 2), .Cells(i, 2)).Copy Destination:=Sheets("Abgänge").Cells(j, 2)
       j = j + 1
     
    Next i
    j = 2
 
    For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row 'Käufer übertragen
       .Range(.Cells(i, 5), .Cells(i, 5)).Copy Destination:=Sheets("Abgänge").Cells(j, 3)
          j = j + 1
    Next i
   
    End With

'ProduktC
   With WbAct.Sheets("ProduktC") 'Artikelnummer Übertragen
     For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
       .Range(.Cells(i, 1), .Cells(i, 1)).Copy Destination:=Sheets("Abgänge").Cells(j, 1)
           j = j + 1
    Next i
    j = 2
    For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row 'Anzahl übertragen
       .Range(.Cells(i, 2), .Cells(i, 2)).Copy Destination:=Sheets("Abgänge").Cells(j, 2)
       j = j + 1
     
    Next i
    j = 2
 
    For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row 'Käufer übertragen
       .Range(.Cells(i, 5), .Cells(i, 5)).Copy Destination:=Sheets("Abgänge").Cells(j, 3)
          j = j + 1
    Next i
   
    End With

End Sub

 

Der Name einer hochgeladenen Mappe wird im Beitrag automatisch angezeigt, sodass es bei Verwendung von aussagekräftigen Namen leichter fällt, sie später im Ablageordner wiederzufinden und sie gedanklich einem bestimmten Thema zuzuordnen. Namen wie Muster*, Test*, Mappe*, Beispiel*, Fehler*, Kalender*, UserForm* , Forum*, Excel* usw. sind so allgemein, dass eine Zuordnung zu einem Thema unmöglich gemacht wird.
Es sollte ein aussagekräftiger Name sein.

Wenn du an Stelle einer Demomappe deine Originalmappe hochladen willst, diese aber sensible Daten enthält, kannst du diese Daten ändern. Schaue Datei
http://hajo-excel.de/gepackt/fremd/Datei_verschluesseln.zip

Das ist nur meine Meinung zu dem Thema.

 

Hallo,

ich nehme an, folgende SUB sollte deinen Wünschen genügen:

Code:

Sub Abgaengeermitteln_Neu()

  Dim WbAct As Workbook 'Diese Arbeitsmappe
  Dim WsI As Worksheet
  Dim WsJ As Worksheet
  Dim iZl As Long
  Dim jZl As Long

  Application.ScreenUpdating = False
 
  Set WbAct = ThisWorkbook
  Set WsJ = WbAct.Worksheets("Abgänge")  'Ziel-Sheet

  jZl = 2
  For Each WsI In WbAct.Worksheets       'Quell-Sheets
    With WsI
      If .Name <> WsJ.Name Then
    
         For iZl = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
            .Cells(iZl, 1).Copy Destination:=WsJ.Cells(jZl, 1) 'Artikelnummer
            .Cells(iZl, 2).Copy Destination:=WsJ.Cells(jZl, 2) 'Anzahl
            .Cells(iZl, 5).Copy Destination:=WsJ.Cells(jZl, 3) 'Käufer
            jZl = jZl + 1
         Next iZl
        
      End If
    End With
  
  Next WsI
 
  Application.ScreenUpdating = True

End Sub

 

Mega! Vielen lieben Dank. Manchmal steht man ja doch ein wenig auf dem Schlauch...