AW: Makro: kopieren
02.01.2006 17:20:53
Daniel
Hi, ich habe es inzwischen selbst geschafft mit Hilfe eines anderen Makros in einer anderen Datei. Hatte mich erinnert, dass ein teil ähnlich war mit dem Spalten löschen.
Danke für die Hilfe!!!
Hier noch der Code:
Sub copy()
Const EZ = 2
Set sh = Sheets("Bericht")
Application.ScreenUpdating = False
With sh
sh.Range(.Cells(EZ, 10), .Cells(.Rows.Count, 10)).ClearContents
sh.Range(.Cells(EZ, 11), .Cells(.Rows.Count, 11)).ClearContents
sh.Range(.Cells(EZ, 12), .Cells(.Rows.Count, 12)).ClearContents
sh.Range(.Cells(EZ, 13), .Cells(.Rows.Count, 13)).ClearContents
End With
nRow = 2
For i = 18 To Sheets("Bericht_Daten").UsedRange.Rows.Count
If Sheets("Bericht_Daten").Cells(i, 1).Value <> "" Then
Sheets("Bericht").Cells(nRow, 10).Value = Sheets("Bericht_Daten").Cells(i, 2).Value
Sheets("Bericht").Cells(nRow, 11).Value = Sheets("Bericht_Daten").Cells(i, 4).Value
Sheets("Bericht").Cells(nRow, 12).Value = Sheets("Bericht_Daten").Cells(i, 5).Value
Sheets("Bericht").Cells(nRow, 13).Value = Sheets("Bericht_Daten").Cells(i, 6).Value
nRow = nRow + 1
End If
Next i
Sheets("Bericht").Select
Columns("J:M").Select
Selection.Sort Key1:=Range("J2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Application.ScreenUpdating = True
End Sub