AW: NEIN. Ist der Code so geheim? ..(owT)
Immanuel
Ach so, nein überhaupt nicht, er ist nur sehr lang!! Also ich werde einfach die wichtigen Dinge reinkopieren, sonst ist er viel zu lang..
Hier ist eine Anfangsversion
Sub SearchForString()
Dim LSearchRow As Integer
Dim LCopyToRow As Integer
On Error GoTo Err_Execute
'Start search in row 4
LSearchRow = 4
'Start copying data to row 2 in Sheet2 (row counter variable)
LCopyToRow = 2
While Len(Range("A" & CStr(LSearchRow)).Value) > 0
'If value in column B = "A", copy entire row to Sheet2
If Range("A" & CStr(LSearchRow)).Value = "A" Then
'Select row in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy
'Paste row into Sheet2 in next row
Sheets("A_").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
'Move counter to next row
LCopyToRow = LCopyToRow + 1
'Go back to Sheet1 to continue searching
Sheets("Sheet1").Select
End If
LSearchRow = LSearchRow + 1
Wend
'Start search in row 4
LSearchRow = 4
'Start copying data to row 2 in Sheet2 (row counter variable)
LCopyToRow = 2
While Len(Range("A" & CStr(LSearchRow)).Value) > 0
'If value in column E = "B", copy entire row to B
If Range("A" & CStr(LSearchRow)).Value = "B" Then
'Select row in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy
'Paste row into Sheet2 in next row
Sheets("B_").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
'Move counter to next row
LCopyToRow = LCopyToRow + 1
'Go back to Sheet1 to continue searching
Sheets("Sheet1").Select
End If
LSearchRow = LSearchRow + 1
Wend
'Position on cell A3
Application.CutCopyMode = False
Range("A3").Select
Sheets("A_").Select
Range("B1:B256").Select
Selection.Copy
Sheets("A").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, transpose:=True
Sheets("B_").Select
Range("B1:B256").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("B").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, transpose:=True
Sheets("Sheet1").Select
Range("A3").Select
'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
Ich hoffe das bringt was..
Danke