Zeilen in anderem Sheet auflisten

Sub test() Dim i As Long, tLR As Long Dim tarWks As Worksheet, srcWks As Worksheet Set srcWks = Worksheets("Tabelle1") Set tarWks = Worksheets("Tabelle2") With srcWks For i = 1 To .Cells(.Rows.Count, 10).End(xlUp).Row If .Cells(i, 10).Value = "x" Then tLR = tarWks.Cells(Rows.Count, 1).End(xlUp).Row + 1 Debug.Print tLR With tarWks .Range(.Cells(tLR, 1), .Cells(tLR, 10)).Value = srcWks.Range(srcWks.Cells(i, 1), _ _ _ _ srcWks.Cells(i, 10)).Value End With End If Next i End With End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo André,
hier dein Makro angepasst und erweitert.
LG
Franz

Sub test()
Dim i As Long, tLR(1 To 2) As Long
Dim iTar As Integer
Dim tarWks(1 To 2) As Worksheet, srcWks As Worksheet
Dim StatusCalc As Long
Set srcWks = Worksheets("Datenbank")
Set tarWks(1) = Worksheets("KST")
Set tarWks(2) = Worksheets("RE-FX")
If MsgBox("Daten aus """ & srcWks.Name & """ nach """ & tarWks(1).Name & """ bzw. """ _
& tarWks(2).Name & """ übertragen?", vbOKCancel + vbQuestion + vbDefaultButton2, _
"Daten übertragen") = vbCancel Then Exit Sub
'Makrobremsen lösen
With Application
StatusCalc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
'    .EnableEvents = False
End With
'Altdaten in den Zielblättern löschen
For iTar = 1 To 2
With tarWks(iTar)
tLR(iTar) = .UsedRange.Row + .UsedRange.Rows.Count - 1
If tLR(iTar) > 1 Then
.Range(.Rows(2), .Rows(tLR(iTar))).Delete
End If
tLR(iTar) = 1
End With
Next
With srcWks
For i = 2 To .Cells(.Rows.Count, 14).End(xlUp).Row 'bis letzte Zeile mit Inhalt in Spalte  _
N
'Wert in Spalte N prüfen
If .Cells(i, 14).Value = 1 Then
'Wert in Spalte E prüfen
Select Case .Cells(i, 5).Text
Case "44005000":    iTar = 1 'KST
Case "44000620":    iTar = 2 'RE-FX
End Select
'Zeilenzähler hochzählen
tLR(iTar) = tLR(iTar) + 1
'Spalten B:C kopieren nach Spalten A:B
srcWks.Range(srcWks.Cells(i, 2), srcWks.Cells(i, 3)).Copy
With tarWks(iTar)
With .Range(.Cells(tLR(iTar), 1), .Cells(tLR(iTar), 2))
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteValues
End With
End With
'Spalten P:V kopieren nach Spalten C:I
srcWks.Range(srcWks.Cells(i, 16), srcWks.Cells(i, 22)).Copy
With tarWks(iTar)
With .Range(.Cells(tLR(iTar), 3), .Cells(tLR(iTar), 9))
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteValues
End With
End With
Application.CutCopyMode = False
End If
Next i
End With
'Makrobremsen zurücksetzen
With Application
.Calculation = StatusCalc
.ScreenUpdating = True
'    .EnableEvents = True
End With
End Sub

Sub Makro1() Application.ScreenUpdating = False Worksheets("KST").UsedRange.Offset(1).ClearContents Worksheets("RE-FX").UsedRange.Offset(1).ClearContents With Worksheets("Datenbank") .Range("$A$1:$V$6").AutoFilter Field:=14, Criteria1:="1" .Range("$A$1:$V$6").AutoFilter Field:=5, Criteria1:="44005000" With .AutoFilter.Range Union(.Offset(1).Resize(.Rows.Count - 1).Columns("B:C"), _ .Offset(1).Resize(.Rows.Count - 1).Columns("P:V")).Copy With Worksheets("KST") .Cells(.Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row, "A").PasteSpecial _ Paste:=xlPasteValuesAndNumberFormats End With End With .Range("$A$1:$V$6").AutoFilter Field:=14, Criteria1:="1" .Range("$A$1:$V$6").AutoFilter Field:=5, Criteria1:="44000620" With .AutoFilter.Range Union(.Offset(1).Resize(.Rows.Count - 1).Columns("B:C"), _ .Offset(1).Resize(.Rows.Count - 1).Columns("P:V")).Copy With Worksheets("RE-FX") .Cells(.Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row, "A").PasteSpecial _ Paste:=xlPasteValuesAndNumberFormats End With End With .Range("A1").AutoFilter End With Application.CutCopyMode = False End Sub

Beliebteste Forumthreads (12 Monate)

Zeilen in anderem Sheet auflisten

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread