VBA - how to copy rows twice based on one cell offering two criteria

Question

the macro I have been using searches my Input sheet for a number in Column G and based on that number copies the entire row of data into a different sheet associated with the number in Column G. For example, if 'Series 3' appears in Column G the macro will copy that row into the sheet named 'C3'. My data set goes from Series 1 up through Series 14 with respective sheets C1 through C14.

The issue - I have numerous cells that contain two numbers: 'Series 4, Series 5' and 'Series 13, Series 14'. I want these rows to be copied twice into both C4 / C5 and C13 / C14, respectively. The current code addresses the 'Series 4, Series 5' option but it lumps all of these rows into the C4 sheet rather than copying into both C4 and C5. Once the macro has been run, I expect the C4 sheet to contain all rows of data with 'Series 4' and 'Series 4, Series 5' in Column G. I expect the C5 sheet to contain all rows with 'Series 5' and 'Series 4, Series 5'. I expect the same pattern for the C13 and C14 sheets as well.

Final notes: (1) the amount of data I need to sort every month fluctuates, (2) there are column headers in the destination sheets, (3) not every row in my Input sheet has data in Column G - these rows should be skipped, and (4) I am a complete novice with VBA

Much thanks in advance!

Sub SortSeries()

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Dim ss1 As Long
Dim cVal As String
Dim lRow As Long
Dim r As Long
Dim t As Long
Dim WS As Worksheet

Set WS = ThisWorkbook.Worksheets("Input") 'Sets WS to your main input sheet
ss1 = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row 'Find last row in input

On Error Resume Next

    For r = ss1 To 2 Step -1                ' Cycle through input from bottom to 2nd row
        t = 0
        cVal = WS.Cells(r, "G").Value2      ' set cVal to = "G" cell value
        t = Right(cVal, Len(cVal) - InStrRev(cVal, " ")) ' Extract rightmost value of "G" cell value
        If t = 5 Then If InStr(1, cVal, 4) Then t = 4 ' if t is 5 double check it isn't the Series 4, Series 5 possibility
        If t > 0 Then                       ' if no number was found then exit loop for this row else:
        With ThisWorkbook.Worksheets("C" & t) ' specify sheet where t is the extracted number
            lRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 ' get lastrow + 1 of the worksheet
            WS.Rows(r).Copy Destination:=.Range("A" & lRow) ' copy row r from WS (Input) to specified t sheet lastrow + 1
        End With
        End If
    Next r

Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

CDP1802 CDP1802 · Accepted Answer · 2021-03-16T22:32:57

Use split to separate values into an array.

Option Explicit

Sub SortSeries()

    Dim ss1 As Long, lRow As Long, r As Long
    Dim cVal As String
    Dim wb As Workbook, ws As Worksheet
    Dim ar As Variant, i As Integer, t As Integer
    
    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Input")
    ss1 = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row
    
    For r = ss1 To 2 Step -1
      
        cVal = ws.Cells(r, "G").Value2
        cVal = Replace(cVal, " ", "") ' remove spaces
        If Len(cVal) > 0 Then ' skip blanks
            ar = Split(cVal, ",")
            For i = 0 To UBound(ar)
                If LCase(ar(i)) Like "series*" Then
               
                    t = CInt(Mid(ar(i), 7))
                    
                    With wb.Sheets("C" & t)
                        lRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
                        ws.Rows(r).Copy Destination:=.Range("A" & lRow)
                    End With
                   
               End If
            Next
        End If
    Next r

End Sub

VBA - how to copy rows twice based on one cell offering two criteria

2 Answers