Zeilen kopieren in andere Tabelle
15.08.2005 20:50:00
Kossmann
ich hatte neulich schonmal das Problem, dass ich von einer Tabelle unter verschiedenen Kriterien Zeilen in neue Tabellenblätter kopieren musste.
Ich hatte von INGi aus dem Forum hier eine sehr gute Lösung erhalten.
Nun musste ich noch einige Spalten hinzufügen. Ich habe den Code dementsprechend abgeändert.
So sieht das funktionierende aus:
Dim rng As Range, ziel As Range
With ThisWorkbook
For Each rng In .Sheets("Eingabe").Range("D9:D" & .Sheets("Eingabe") _
.Range("D65536").End(xlUp).Row)
Select Case rng
Case 817
Select Case Len(.Sheets("Tabelle817").Range("D9"))
Case 0
Set ziel = .Sheets("Tabelle817").Range("D9")
Case Else
Set ziel = .Sheets("Tabelle817").Range("D65536").End(xlUp).Offset(1, 0)
End Select
Case 834
Select Case Len(.Sheets("Tabelle834").Range("D9"))
Case 0
Set ziel = .Sheets("Tabelle834").Range("D9")
Case Else
Set ziel = .Sheets("Tabelle834").Range("D65536").End(xlUp).Offset(1, 0)
End Select
Case 835
Select Case Len(.Sheets("Tabelle835").Range("D9"))
Case 0
Set ziel = .Sheets("Tabelle835").Range("D9")
Case Else
Set ziel = .Sheets("Tabelle835").Range("D65536").End(xlUp).Offset(1, 0)
End Select
Case 843
Select Case Len(.Sheets("Tabelle843").Range("D9"))
Case 0
Set ziel = .Sheets("Tabelle843").Range("D9")
Case Else
Set ziel = .Sheets("Tabelle843").Range("D65536").End(xlUp).Offset(1, 0)
End Select
Case 846
Select Case Len(.Sheets("Tabelle846").Range("D9"))
Case 0
Set ziel = .Sheets("Tabelle846").Range("D9")
Case Else
Set ziel = .Sheets("Tabelle846").Range("D65536").End(xlUp).Offset(1, 0)
End Select
End Select
On Error GoTo Fehlerbehandlung
rng.EntireRow.Copy Destination:=ziel.Offset(0, -3)
Next 'rng
End With
Exit Sub
Fehlerbehandlung:
Select Case Err.Number
Case 1004
rng.Parent.Activate
rng.Activate
MsgBox "Die Tabelle " & Chr(34) & ziel.Parent.Name & Chr(34) & _
" ist voll. Kopiervorgang abgebrochen. Die Zeilen vor der Markierung wurden jedoch kopiert."
End Select
End Sub
Nun ist die neue Spalte die für die Sortierung relevant ist F. Ich habe einfach alles mit D in F abgeändert:
Dim rng As Range, ziel As Range
With ThisWorkbook
For Each rng In .Sheets("Eingabe").Range("F9:F" & .Sheets("Eingabe") _
.Range("F65536").End(xlUp).Row)
Select Case rng
Case 817
Select Case Len(.Sheets("Tabelle817").Range("F9"))
Case 0
Set ziel = .Sheets("Tabelle817").Range("F9")
Case Else
Set ziel = .Sheets("Tabelle817").Range("F65536").End(xlUp).Offset(1, 0)
End Select
Case 834
Select Case Len(.Sheets("Tabelle834").Range("F9"))
Case 0
Set ziel = .Sheets("Tabelle834").Range("F9")
Case Else
Set ziel = .Sheets("Tabelle834").Range("F65536").End(xlUp).Offset(1, 0)
End Select
Case 835
Select Case Len(.Sheets("Tabelle835").Range("F9"))
Case 0
Set ziel = .Sheets("Tabelle835").Range("F9")
Case Else
Set ziel = .Sheets("Tabelle835").Range("F65536").End(xlUp).Offset(1, 0)
End Select
Case 843
Select Case Len(.Sheets("Tabelle843").Range("F9"))
Case 0
Set ziel = .Sheets("Tabelle843").Range("F9")
Case Else
Set ziel = .Sheets("Tabelle843").Range("F65536").End(xlUp).Offset(1, 0)
End Select
Case 846
Select Case Len(.Sheets("Tabelle846").Range("F9"))
Case 0
Set ziel = .Sheets("Tabelle846").Range("F9")
Case Else
Set ziel = .Sheets("Tabelle846").Range("F65536").End(xlUp).Offset(1, 0)
End Select
End Select
On Error GoTo Fehlerbehandlung
rng.EntireRow.Copy Destination:=ziel.Offset(0, -3)
Next 'rng
End With
Exit Sub
Fehlerbehandlung:
Select Case Err.Number
Case 1004
rng.Parent.Activate
rng.Activate
MsgBox "Die Tabelle " & Chr(34) & ziel.Parent.Name & Chr(34) & _
" ist voll. Kopiervorgang abgebrochen. Die Zeilen vor der Markierung wurden jedoch kopiert."
End Select
End Sub
Doch wenn ich das Makro nun starte springt es beim ersten Wert sofort zur Fehlerbehandlung.
Wo ist der Fehler?
Was hab ich falsch gemacht?
Was muss noch geändert werden?
Danke für eure Hilfe