AW: Hilfe, dringend Lösung gesucht!!!!!!!
19.07.2011 12:25:53
René
Hallo Manu,
mal ein Ansatz.
Gruß René
Sub tabellen_zusammenfassen()
Dim refNr As Range, sNr As Range
Dim lZeile1 As Long, lZeile2 As Long, lZeile3 As Long
Dim wks1 As Worksheet, wks2 As Worksheet, wks3 As Worksheet
Set wks1 = Worksheets("Tabelle R")
Set wks2 = Worksheets("Tabelle P")
Set wks3 = Worksheets("Tabelle M")
lZeile1 = wks1.Cells(Rows.Count, 1).End(xlUp).Row
lZeile2 = wks2.Cells(Rows.Count, 1).End(xlUp).Row
lZeile3 = wks3.Cells(Rows.Count, 1).End(xlUp).Row
If Not lZeile1 = 1 Then wks1.Range(wks1.Cells(2, 1), wks1.Cells(lZeile1, 18)).ClearContents
lZeile1 = 2
For Each refNr In wks2.Range(wks2.Cells(2, 1), wks2.Cells(lZeile2, 1))
If refNr "" Then
wks1.Cells(lZeile1, 1) = refNr.Value
wks1.Cells(lZeile1, 2) = refNr.Offset(0, 1)
wks1.Cells(lZeile1, 3) = refNr.Offset(0, 2)
wks1.Cells(lZeile1, 4) = refNr.Offset(0, 3)
wks1.Cells(lZeile1, 5) = refNr.Offset(0, 4)
wks1.Cells(lZeile1, 6) = refNr.Offset(0, 5)
wks1.Cells(lZeile1, 7) = refNr.Offset(0, 6)
wks1.Cells(lZeile1, 8) = refNr.Offset(0, 7)
wks1.Cells(lZeile1, 9) = refNr.Offset(0, 8)
wks1.Cells(lZeile1, 10) = refNr.Offset(0, 9)
For Each sNr In wks3.Range(wks3.Cells(2, 1), wks3.Cells(lZeile3, 1))
If refNr = sNr Then
wks1.Cells(lZeile1, 1) = sNr.Value
wks1.Cells(lZeile1, 11) = sNr.Offset(0, 1)
wks1.Cells(lZeile1, 12) = sNr.Offset(0, 2)
wks1.Cells(lZeile1, 13) = sNr.Offset(0, 3)
wks1.Cells(lZeile1, 14) = sNr.Offset(0, 4)
wks1.Cells(lZeile1, 15) = sNr.Offset(0, 5)
wks1.Cells(lZeile1, 16) = sNr.Offset(0, 6)
wks1.Cells(lZeile1, 17) = sNr.Offset(0, 7)
wks1.Cells(lZeile1, 18) = sNr.Offset(0, 8)
lZeile1 = lZeile1 + 1
End If
Next
lZeile1 = lZeile1 + 1
End If
Next
If wks1.Cells(3, 1).Value = "test1" Then
Range("B2:I2").Select
Selection.Copy
Range("B3").Select
ActiveSheet.Paste
End If
If wks1.Cells(4, 1).Value = "test1" Then
Range("B3:I3").Select
Selection.Copy
Range("B4").Select
ActiveSheet.Paste
End If
If wks1.Cells(6, 1).Value = "test2" Then
Range("B5:I5").Select
Selection.Copy
Range("B6").Select
ActiveSheet.Paste
End If
If wks1.Cells(7, 1).Value = "test2" Then
Range("B6:I6").Select
Selection.Copy
Range("B7").Select
ActiveSheet.Paste
End If
Set wks1 = Nothing
Set wks2 = Nothing
Set wks3 = Nothing
End Sub