copy rows based on cell value

[Przemek]

Hi,

I have to split all records in my sheet into 2 different sheets based
on value (if value contains given string or not) in column C. Sheet
"wejscie nieuslugi" is source. Here is my code:

Sub Copy_Rows_Wejscie_Nieuslugi(WorkbookName As String)
Dim RngCol As Range
Dim i As Range
Workbooks(WorkbookName).Activate
ActiveWorkbook.Worksheets("wejscia nieuslugi").Select

' looking for value in column "C"
Set RngCol = Range("C2", Range("C" & Rows.Count).End(xlUp).Address)

' adding first sheet
Dim wsA As Worksheet
Dim STarget As String
STarget = "input A"
Dim idx As Long 'sheet index
idx = ActiveWorkbook.Worksheets.Count
ActiveWorkbook.Worksheets.Add(After:=Worksheets(idx)).Name = STarget
'adding sheet

With ActiveWorkbook.Worksheets("wejscia nieuslugi") 'copy headings
..Rows(1).Copy Destination:=ActiveWorkbook.Worksheets("input
A").Range("A1")
End With
'adding second sheet
Dim wsT As Worksheet
STarget = "input B"
idx = ActiveWorkbook.Worksheets.Count
ActiveWorkbook.Worksheets.Add(After:=Worksheets(idx)).Name = STarget
'adding sheet


With ActiveWorkbook.Worksheets("wejscia nieuslugi") 'copy headings
..Rows(1).Copy Destination:=ActiveWorkbook.Worksheets("input
B").Range("A1")
End With

'copy rows
For Each i In RngCol
If i.Value = "ABC" Then
i.Rows.Copy Destination:=ActiveWorkbook.Worksheets("input
A").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Else
i.Rows.Copy Destination:=ActiveWorkbook.Worksheets("input
B").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
End If
Next i
End Sub

My problem is, that I don't know how to write If-Then-Else condition,
which would check if cell in column C contains value ABC (it could be
ABC BC, ABC DA - these meets my criteria) and copy entire row into
destination.

TIA

Przemek

 

[JE McGimpsey]

One way:

Public Sub Copy_Rows_Wejscie_Nieuslugi(WorkbookName As String)
Dim wsA As Worksheet
Dim wsB As Worksheet
Dim RngCell As Range
With Workbooks(WorkbookName)
Set wsA = .Worksheets.Add(After:=.Sheets(.Sheets.Count))
Set wsB = .Worksheets.Add(After:=.Sheets(.Sheets.Count))
wsA.Name = "input A"
wsB.Name = "input B"
With .Worksheets("wejscia nieuslugi")
.Rows(1).Copy Destination:=wsA.Range("A1")
.Rows(1).Copy Destination:=wsB.Range("A1")
For Each RngCell In .Range("C2:C" & _
.Range("C" & .Rows.Count).End(xlUp).Row)
If RngCell.Value Like "*ABC*" Then
With wsA
RngCell.EntireRow.Copy Destination:= _
.Range("A" & .Rows.Count).End( _
xlUp).Offset(1, 0)
End With
ElseIf RngCell.Value Like "*DEF*" Then
With wsB
RngCell.EntireRow.Copy Destination:= _
.Range("A" & .Rows.Count).End( _
xlUp).Offset(1, 0)
End With
End If
Next RngCell
End With
End With
End Sub

 

[Przemek]

Tx for help mate, it works

Przemek