AW: Makro - kopieren mit Bedingung
01.03.2020 18:20:29
Regina
Hi Markus,
dann teste mal den folgenden Code. Das Gnaze wird etwas länger, weil jetzt zeilenweise geprüft werden muss, was in Spalte A steht.
Deiner Anmerkung im Code hab eich entnommen, dass das Ergebnis in eine neue Datei geschrieben werden soll, das macht der Code.
Schau mal, ob das so passt (bei den beiden If-Zeilen musst Du die Zeilenumbrüche wieder rausnehmen, die die Forumssoftware hier einbaut).
Sub kopieren()
'Inhalte kopieren - Benötigt werden von Betrag bis Verwendungszweck
Dim i As Integer
Dim LRow As Long
Dim lng_zeile As Long
Dim lng_ziel_zeile As Long
Dim obj_wkb_quelle As Workbook
Dim obj_wkb_ziel As Workbook
Dim obj_wks_ziel As Worksheet
Set obj_wkb_quelle = ThisWorkbook
Application.ScreenUpdating = False
' Neu Exceldatei
Set obj_wkb_ziel = Workbooks.Add
Set obj_wks_ziel = obj_wkb_ziel.Worksheets(1)
lng_ziel_zeile = 2
For i = 1 To obj_wkb_quelle.Worksheets.Count
With obj_wkb_quelle.Worksheets(i)
' Einmalig Überschriften kopieren
If i = 1 Then
.Range("A1:AR1").Copy obj_wks_ziel.Cells(1, 1)
End If
' Letzte zeile in Quellsheet ermitteln
LRow = .Cells(Rows.Count, 1).End(xlUp).Row
For lng_zeile = 2 To LRow - 1
If .Cells(lng_zeile, 1) "Rülas" And .Cells(lng_zeile, 1) "Überweiser" And . _
Cells(lng_zeile, 1) "NB-Gutschrift" And _
.Cells(lng_zeile, 1) "Scheck" And .Cells(lng_zeile, 1) "Retour Erstattung" _
And Right(.Cells(lng_zeile, 1), 8) "Ergebnis" Then
.Range("A" & lng_zeile & ":AR" & lng_zeile).Copy
obj_wks_ziel.Cells(lng_ziel_zeile, 1).PasteSpecial xlPasteValues
lng_ziel_zeile = lng_ziel_zeile + 1
ElseIf .Cells(lng_zeile, 1) = "Rülas Ergebnis" Or .Cells(lng_zeile, 1) = "Ü _
berweiser Ergebnis" Or .Cells(lng_zeile, 1) = "NB-Gutschrift Ergebnis" Or _
.Cells(lng_zeile, 1) = "Scheck Ergebnis" Or .Cells(lng_zeile, 1) = "Retour _
Erstattung Ergebnis" Then
obj_wks_ziel.Cells(lng_ziel_zeile, 1) = .Cells(lng_zeile, 1).Value
obj_wks_ziel.Cells(lng_ziel_zeile, 8) = .Cells(lng_zeile, 1).Value
obj_wks_ziel.Cells(lng_ziel_zeile, 2) = .Cells(lng_zeile, 2).Value
lng_ziel_zeile = lng_ziel_zeile + 1
End If
Next
End With
Next
Application.ScreenUpdating = True
End Sub