AW: Bereich markieren kopieren
31.05.2010 14:55:26
fcs
Hallo Tom,
hier meine VBA- Lösung. Die Ausführung kann schon ein paar Sekunden dauern.
Der Fortschritt wird unten in der Statuszeile angezeigt.
Gruß
Franz
Sub Copy_Z5101()
Dim wksJournal As Worksheet, Zeile_J1 As Long, Zeile_J2 As Long, LetzteZeile As Long
Dim wksZiel As Worksheet, Zeile_Tab2 As Long
Const sSuchen1 As String = "Z 5101" 'Suchtext 1. zeile
Const sSuchen2 As String = "-----" 'Suchtext letzte Zeile
Set wksJournal = Worksheets("Journal") 'Anpassen!
Set wksZiel = Worksheets("Tabelle2") 'Anpassen!
'Startzeile für das Einfügen in Tabelle 2
Zeile_Tab2 = wksZiel.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
Application.ScreenUpdating = False
With wksJournal
LetzteZeile = .Cells(.Rows.Count, 1).End(xlUp).Row
'Zellen in Spalte A (1) abarbeiten
For Zeile_J2 = 1 To LetzteZeile
If Left(.Cells(Zeile_J2, 1), Len(sSuchen1)) = sSuchen1 Then
Zeile_J1 = Zeile_J2 'Zeile mit Suchbegriff 1 merken
End If
If Left(.Cells(Zeile_J2, 1), Len(sSuchen2)) = sSuchen2 And Zeile_J1 0 Then
'Spalten 1 bis 9 des Zeielnbereichs kopieren
.Range(.Cells(Zeile_J1, 1), .Cells(Zeile_J2, 9)).Copy Destination:=wksZiel.Cells( _
Zeile_Tab2, 1)
'Nächste Einfüge Zeile in Tabelle 2
Zeile_Tab2 = Zeile_Tab2 + (Zeile_J2 - Zeile_J1) + 1
Application.StatusBar = "Bearbeite Zeile " & Zeile_J2 & " von " & LetzteZeile
Zeile_J1 = 0
End If
Next
Application.CutCopyMode = False
End With
With Application
.ScreenUpdating = True
.StatusBar = False
End With
MsgBox "Fertig"
End Sub