Loop Function

[Sacha19]

Hi Everyone! My first attempt with loop function failed. I've created this macro without the loop (ridiculously repetitive), and it works as intended. I tried to add a couple of loop functions, and nothing happens. Not even any bugs to point me in a direction. So, I'm sure I've done something really dumb, but would appreciate any correction.

What I was going for: Columns A-C have data (text, not numbers), Columns D-J may have an 'X'. The first row contains text header for the column. If there is an 'X', I'd like to copy the info in columns A-C, of the X-corresponding row, and past the information in a worksheet named the same as the header of the respective column.

Here's what I did that doesn't work: ... and thanks for taking the time to read!

Dim c As Range
Dim IRow As Long, lastrow As Long
Dim rSource As Range
Dim ws1 As Worksheet
'(Note: everything incorporating these last 3 variables is when the macro failed)
Dim StartColumn As Integer
Dim EndColumn As Integer
Dim TestName As String


'> Define ws1: where 'X' needs to be checked
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Application.ScreenUpdating = False

With ws1
'> Find X's in Col D-J
If Application.WorksheetFunction.<wbr>CountA(.Cells) <> 0 Then
lastrow = .Columns(“D:J”).Find(What:="*"<wbr>, _
After:=.Range(“D1”), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
lastrow = 1
End If

'> Set input range to loop through columns D-J
For StartColumn = 4 To EndColumn
EndColumn = 9
Set rSource = .Range(.Cells(1, StartColumn), .Cells(25, StartColumn))
TestName = Cells(1, StartColumn).Value

'> Sheet1: For each StartColumn with X, copy column A,B, C of the same row and paste to the worksheet (at first blank row of column C) named the same text as StartColumn header
For Each c In rSource
If c.Value = "X" Then
.Range(.Cells(c.Row, 1), .Cells(c.Row, 3)).Copy
Sheets(TestName).<wbr>Select
lMaxRows = Cells(Rows.Count, "C").End(xlUp).Row
Range("C" & lMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

IRow = IRow + 1
End If
Next
Next StartColumn
End With

End Sub

 

[Beyond_avarice]

If it's ok to sort your data; try using the following methodology:

Dim lRow As Long, xStart As Long, xEnd As Long
lRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row


''Sort Column "C"
Worksheets("Sheet1").Range("A1:C1").AutoFilter

  Worksheets("Sheet1").AutoFilter.Sort.SortFields.add Key:=Range _
        ("C1:C" & lRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal

    With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 

''With sorted column, identify start and end row of now grouped "x" information
On Error Resume Next

 xStart = Worksheets("Sheet1").Columns("C").Find("x").Row
             If xStart <> 0 Then
               xStart = Worksheets("Sheet1").Columns("C").Find("x").Row = 0 Then                        ''Find first row
               xEnd = Worksheets("Sheet1").Columns("C").Find("x", , , , , xlPrevious).Row             ''Find last row
               xRange = xEnd -xStart+1
             End If

''Populate
    Worksheets(TestName).Range("A1:C" & xRange).value = Worksheets("Sheet1").Range("A" & xStart & ":C" & xEnd).value

 

[My Aswer Is This]

Try this:

Sub Test_Copy_Row()
Application.ScreenUpdating = False
On Error GoTo M
Dim i As Long
Dim Lastrow As Long
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Dim c As Range
For i = 1 To Lastrow
    For Each c In Range(Cells(i, "E"), Cells(i, "J"))
        If c.Value = "X" Then
            Range(Cells(i, "A"), Cells(i, "C")).Copy _
Sheets(Cells(1, c.Column).Value).Cells(Sheets(Cells(1, c.Column).Value).Cells(Rows.Count, "A").End(xlUp).Row + 1, "A")
        
        End If
    Next
Next
Application.ScreenUpdating = True
Exit Sub
M:
MsgBox "No such sheet exist"
Application.ScreenUpdating = True
End Sub