Office: Zeilen kopieren wenn Wert gefunden ist...

Hallo Zusammen!
Kann mir jemand helfen? Mir fehlen leider die VBA-Kenntnisse… Ich sollte folgendes haben.

Ich habe im Excel 4 Registerkarten: All, Q1, Q2, Q3, Q4
Das Makro sollte in der Registerkarte „All“ in der Spalte „S“ nach dem Text „Q1“ suchen. Wenn vorhanden, sollte es dann die ganze Zeile kopieren und in die Registerkarte „Q1“ kopieren. Wenn aber in der Zelle der Spalte „S“ kein Text drin ist, sollte die Zeile nicht kopiert werden. Er sollte dann das Gleiche mit dem Text „Q2“, „Q3“, „Q4“ machen. Das heisst in Spalte „S“ suchen, wenn vorhanden, in die entsprechende Registerkarte Q2, Q3, Q4 kopieren aber nicht wenn die Zelle in Spalte „S“ leer ist. Wenn‘s möglich ist, sollte das Makro beim Öffnen des Dokumentes ausgeführt werden.
Ich wäre wirklich froh, wenn mir jemand helfen könnte. Ich habe im Internet gesucht, aber ich bekomm es einfach nicht hin. Herzlichen Dank!!!*Smilie

:)

 

Hallo xyz

5 oder?

Was hast du denn, auf was man aufbauen kann?

Grüße JAck

 

Sorry, 5 Registerkarten. Die Hauptregisterkarte ist "All" dort sind die Daten

Habe gerade etwas gefunden das teilweise funktioniert. Aber es kopiert mir auch Zellen die in der Spalte "S" leer sind und beim öffnen wird das Makro nicht automatisch ausgeführt.


Sub SearchForString()

Dim LSearchRow As Integer
Dim LCopyToRow As Integer

On Error GoTo Err_Execute

'Start search in row 8
LSearchRow = 4

'Start copying data to row 8 in Q1 (row counter variable)
LCopyToRow = 2

While Len(Range("A" & CStr(LSearchRow)).Value) > 0

'If value in column S = "Q1", copy entire row to SheetQ1
If Range("S" & CStr(LSearchRow)).Value = "Q1" Then

'Select row in All to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy

'Paste row into Q1 in next row
Sheets("Q1").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste

'Move counter to next row
LCopyToRow = LCopyToRow + 1

'Go back to All to continue searching
Sheets("All").Select

ElseIf Range("S" & CStr(LSearchRow)).Value = "Q2" Then

'Select row in All to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy

'Paste row into Q2 in next row
Sheets("Q2").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste

'Move counter to next row
LCopyToRow = LCopyToRow + 1

'Go back to All to continue searching
Sheets("All").Select

ElseIf Range("S" & CStr(LSearchRow)).Value = "Q3" Then

'Select row in All to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy

'Paste row into Q3 in next row
Sheets("Q3").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste

'Move counter to next row
LCopyToRow = LCopyToRow + 1

'Go back to All to continue searching
Sheets("All").Select

ElseIf Range("S" & CStr(LSearchRow)).Value = "Q4" Then

'Select row in All to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy

'Paste row into Q4 in next row
Sheets("Q4").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste

'Move counter to next row
LCopyToRow = LCopyToRow + 1

'Go back to All to continue searching
Sheets("All").Select

End If

LSearchRow = LSearchRow + 1

Wend

'Position on cell A3
Application.CutCopyMode = False
Range("A3").Select

MsgBox "All matching data has been copied."

Exit Sub

Err_Execute:
MsgBox "An error occurred."

End Sub

 

Lade mal bitte eine Mustermappe hoch. ich schreib mal was sinnvolles

Grüße

Ps.: Ohne Muster derweil folgender Ansatz

Code:

Grüße

 

...oder so...

Code:

 

Hallo jack_D

Du bist ganz schön fleissig! Herzlichen Dank!*Smilie

Bei diesem Makro, kopiert es nicht die ganze Zeile 1:1
Ich habe die Datei hochgeladen.
Danke dir nochmals für deine Hilfe...
Gruss
Afrodite

 

Danke für die Blumen ,
Aber das ist der Code von xlph
Wenn ich den mal so überfliege könnt ich mir vorstellen das der columnindex nicht Passt.

Änder mal lnglastcolumn auf deine letzte Spalte (nr).
Dann müsste es gehen.

Grüße

 

xxxxxxx

 

Hallo jack_D
dein code hat nun funktioniert. Vorher hat es irgendwie nicht geklappt...
Könntest es mir bitte so einrichten, dass das Makro beim Öffnen des Files automatisch ausgeführt wird? das wäre Super! Vielen vielen Dank!

Sub SearchQuarter()
With Worksheets("All")
For i = 1 To .Cells(Rows.Count, 19).End(xlUp).Row
Select Case .Cells(i, 19).Value
Case Is = "Q1"
.Rows(i).EntireRow.Copy Destination:=Worksheets("Q1").Range("A" & Worksheets("Q1").Cells(Rows.Count, 19).End(xlUp).Row + 1)
Case Is = "Q2"
.Rows(i).EntireRow.Copy Destination:=Worksheets("Q2").Range("A" & Worksheets("Q2").Cells(Rows.Count, 19).End(xlUp).Row + 1)
Case Is = "Q3"
.Rows(i).EntireRow.Copy Destination:=Worksheets("Q3").Range("A" & Worksheets("Q3").Cells(Rows.Count, 19).End(xlUp).Row + 1)
Case Is = "Q4"
.Rows(i).EntireRow.Copy Destination:=Worksheets("Q4").Range("A" & Worksheets("Q4").Cells(Rows.Count, 19).End(xlUp).Row + 1)
End Select
Next i
End With
End Sub

 

Moin Moin,

Nur der Form halber. Du hast erst XLPH seinen Code verwendet. Meiner hat die ganze Zeit funktioniert. Aber auch nur, weil ich einfach stumpf die Zeilen kopiert hab. XLPH sein Code ist grundsätzlich besser und schneller!

Zu deiner Bitte. Das der Code automatisch beim öffnen der Mappe startet erreichst du indem du den folgenden Code in das TabellenModul "DieseArbeitsmappe" kopierst
Code:

Grüße

Rückmeldung und Bewertung wär nett

 

Lieber jack_D

Danke nochmals für deine rasche und professionelle Hilfe! Alles funktioniert perfekt!!! Auch der Code von xlph funktioniert wunderbar!

LG
Afrodite

Grüße

Rückmeldung und Bewertung wär nett

 

Perfekt!

Danke für die Rückmeldung!

Beste Grüße

 

xxxxx