Clever-Excel-Forum

Hallo an euch Profis

Ich suche noch immer nach eine Lösung für mein Problem
Mit unterem Code kopiere ich die Zeile, wo in der Spalte C eine "4" steht. Ich müsste den aber so umbauen, dass die Zeile kopiert wird wenn eine "3" und/ oder "4" steht.

Ich hätte das mit einem 2.Code gelöst. Das Problem ist, dass dann zuerst die Zeilen mit "4" und dann "3" kopiert. Da passt die Reihung natürlich nicht mehr

Code:
Sub BedingteZeilenKopieren()

Dim Zeile As Long

Dim ZeileMax As Long

Dim n As Long

Dim Suche As String

Dim Zielblatt As Worksheet, Quellblatt As Worksheet

Set Quellblatt = Worksheets("e466abwb")  'Quelle anpassen

Set Zielblatt = Worksheets("Tabelle1") 'Zielsheet als vorhandenens Sheet setzen

'Set Zielblatt = Worksheets.Add          'neues Sheet anlegen

Suche = "4"  'Suchbegriff

With Quellblatt

  ZeileMax = .UsedRange.Rows.Count  'letzte Zeile im Quellsheet

  n = 2                              'erste Zeile im ZielSheet

  For Zeile = 2 To ZeileMax          'Quellsheet zeilenweise durchlaufen

    If Left(.Cells(Zeile, 3).Value, Len(Suche)) = Suche Then    'prüfe Suchbegriff in Spalte c

        .Rows(Zeile).Copy Destination:=Zielblatt.Rows(n)  'Zeile kopieren in Zeile n

        n = n + 1                    'Nächste Zeile im Zielsheet setzen

    End If

  Next Zeile

End With

End Sub

Danke für eure Hilfe
LG
Michael

Hi,

ungetestet:

Dim Suche As String, Suche2 As String
Dim Zielblatt As Worksheet, Quellblatt As Worksheet
Set Quellblatt = Worksheets("e466abwb") 'Quelle anpassen
Set Zielblatt = Worksheets("Tabelle1") 'Zielsheet als vorhandenens Sheet setzen
'Set Zielblatt = Worksheets.Add 'neues Sheet anlegen
Suche = "4" 'Suchbegriff
Suche2 = "3"

With Quellblatt

ZeileMax = .UsedRange.Rows.Count 'letzte Zeile im Quellsheet
n = 2 'erste Zeile im ZielSheet
For Zeile = 2 To ZeileMax 'Quellsheet zeilenweise durchlaufen
If Left(.Cells(Zeile, 3).Value, Len(Suche)) = Suche Or Left(.Cells(Zeile, 3).Value, Len(Suche)) = Suche2 Then

Ich glaube ich spinne

Ist das wirklich so einfach für dich??? Und das ungetestet?? das klappt. Ich hab 2 Tage gegoogelt. D A N K E

Ein Frage hätte ich noch (nur wenns nicht umständlich ist)
Wenn ich nicht die Ganze Zeile sondern nur "B" und "C" kopieren will
Was müsste ich da ändern

.Rows(Zeile).Copy Destination:=Zielblatt.Rows(n) 'Zeile kopieren in Zeile n

LG
Michael

Hallo,

z.B. so:

Code:
Sub BedingteZeilenKopieren()

  Dim Zeile As Long

  Dim ZeileMax As Long

  Dim i As Long, n As Long

  Dim Suche As Variant

  Dim Zielblatt As Worksheet, Quellblatt As Worksheet

  Set Quellblatt = Worksheets("e466abwb")  'Quelle anpassen

  Set Zielblatt = Worksheets("Tabelle1") 'Zielsheet als vorhandenens Sheet setzen

  Set Zielblatt = Worksheets.Add          'neues Sheet anlegen

  Suche = Array("3", "4") 'Suchbegriffe

  With Quellblatt

    ZeileMax = .UsedRange.Rows.Count  'letzte Zeile im Quellsheet

    n = 2                              'erste Zeile im ZielSheet

    For Zeile = 2 To ZeileMax          'Quellsheet zeilenweise durchlaufen

      For i = LBound(Suche) To UBound(Suche)

        If Left(.Cells(Zeile, 3).Value, Len(Suche(i))) = Suche(i) Then     'prüfe Suchbegriff in Spalte c

          .Rows(Zeile).Copy Destination:=Zielblatt.Rows(n)  'Zeile kopieren in Zeile n

          n = n + 1                    'Nächste Zeile im Zielsheet setzen

          Exit For

        End If

      Next i

    Next Zeile

  End With

End Sub

Gruß Uwe

So Danke

Ihr seid echt der Wahnsinn

LG
Michael

Hi,

ebenfalls ungetestet:

.Range("B" & Zeile, "C" & Zeile).Copy Destination:=Zielblatt.Range("B" & n)

Damit wird im Zielblatt auch ab Spalte B eingefügt. Willst Du dort eine andere erste Spalte haben, musst Du dieses B entsprechend anpassen.

Hallo Michael,

(09.01.2022, 15:33)Eizi100 schrieb: [ -> ]Wenn ich nicht die Ganze Zeile sondern nur "B" und "C" kopieren will
Was müsste ich da ändern

.Rows(Zeile).Copy Destination:=Zielblatt.Rows(n) 'Zeile kopieren in Zeile n

.Cells(Zeile, 2).Resize(, 2).Copy Destination:=Zielblatt.Cells(n, 1)

Gruß Uwe

Jetzt kann ich beruhigt in den Nachtdienst fahren
perfetto

Danke nochmals

LG
Michael

Eizi100

{Boris}

Eizi100

Kuwer

Eizi100

{Boris}

Kuwer

Eizi100