AW: Spalten mehrere Tabellen zusammenfügen
07.04.2021 15:07:24
peterk
Hallo
In einer Sub
Sub Test1()
Dim QWks1 As Worksheet
Dim QWks2 As Worksheet
Dim ZWks As Worksheet
Dim rZelle1 As Range
Dim rZelle2 As Range
Dim aUeberschr As Variant
Dim iIndex As Integer
Dim iSpalte As Integer
Dim lRowQ1 As Integer
Dim lRowQ2 As Integer
Dim lRowZ As Integer
aUeberschr = Array("Nummer", "Bezeichnung", "Gebinde Inhalt", "Gebinde pro Palett", "Inhalt _
pro Sack", "Inhalt pro Karton", "Sack pro Karton", "Minimale Losgrösse", "Minimale Losgrösse auf Stammnummer", "Losgrösse Rundungsfaktor", "Maximale Losgrösse", "Losgrösse kalt.", "Optimale Losgrösse", "Soll-Stundenleistung")
Application.ScreenUpdating = False
Set QWks1 = Worksheets("Stammdaten1")
Set QWks2 = Worksheets("Stammdaten2")
Set ZWks = Worksheets("Zusammenzug")
ZWks.Cells.ClearContents
With QWks1
For iIndx = 0 To UBound(aUeberschr)
Set rZelle1 = .Rows(1).Find(aUeberschr(iIndx), LookAt:=xlWhole, LookIn:=xlValues)
If Not rZelle1 Is Nothing Then
iSpalte = iSpalte + 1
lRowQ1 = .Cells(.Rows.Count, rZelle1.Column).End(xlUp).Row
.Range(.Cells(1, rZelle1.Column), .Cells(lRowQ1, rZelle1.Column)).Copy _
Destination:=ZWks.Cells(1, iSpalte)
lRowZ = ZWks.Cells(ZWks.Rows.Count, iSpalte).End(xlUp).Row
With QWks2
Set rZelle2 = .Rows(1).Find(aUeberschr(iIndx), LookAt:=xlWhole, LookIn:= _
xlValues)
If Not rZelle2 Is Nothing Then
lRowQ2 = .Cells(.Rows.Count, rZelle2.Column).End(xlUp).Row
If lRowQ2 > 1 Then
.Range(.Cells(2, rZelle2.Column), .Cells(lRowQ2, rZelle2.Column)).Copy _
Destination:=ZWks.Cells(lRowZ + 1, iSpalte)
End If
End If
End With
End If
Next iIndx
End With
Application.ScreenUpdating = True
End Sub