VBA Copy and Paste Data with Matching Sheet Name and Multiple Criteria

Question

Im new to VBA so I am not that good. This a follow up question from my first question. VBA Copy and Paste Data with Matching Worksheet Name

I have a workbook containing worksheets "Summary" (where all data are consolidated, as shown in Fig.1), "8","9","10". I wanted to copy the data from "Summary" with the condition that if cell in Column A contains the worksheet name (8,9 or 10), that cell's row and Column C to E will pasted to the worksheet with matching name (shown in Fig.2). The data will be pasted in fixed Ranges C7 to E7, C14 to E14, C21 to E21 etc etc (7 increment). However, if the consecutive rows in Column B of "Summary" have equal values, they will be pasted beside each other (vague).For example, cells in Column A rows 2 to 6 in "Summary" contains "8", but column B rows 2 and 3 have similar values, thus Columns C to E rows 2 to 6 will be copied and pasted to sheet "8" at columns C7,C8, C14, C21 etc as shown in Fig 2. Link to my macro file: https://drive.google.com/file/d/18UalCvxIXuP6imVWZsWLRZPghMqogZp8/view?usp=sharing

I have the ff code from the previous thread maybe you can add or modify something:

Sub Copy_Data()
Dim lastRow As Long, offsetRow As Long, i As Long, No As String, NOSheet As Worksheet, auxRow As Long, summarySheet As Worksheet
Set summarySheet = Worksheets("Summary")
lastRow = summarySheet.Columns("A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
offsetRow = 7
For i = 2 To lastRow
    No = Cells(i, "A")
    Set NOSheet = Worksheets(No)
    auxRow = NOSheet.Columns("C").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    If auxRow > 1 Then auxRow = auxRow + 2
    If auxRow = 1 Then auxRow = offsetRow
    NOSheet.Cells(auxRow, "C") = summarySheet.Cells(i, "C")
    NOSheet.Cells(auxRow, "D") = summarySheet.Cells(i, "D")
    NOSheet.Cells(auxRow, "E") = summarySheet.Cells(i, "E")
Next i

End Sub

Thank you for your help!!!

marsidev marsidev · Accepted Answer · 2021-05-31T20:08:59

In order to compare SMR column I also copied that column into sheets 8,9,10. Also I added some comments.

Sub Copy_Data()
    Dim lastRow As Long, firstRowToCopyData As Long, i As Long, No As Integer, NOSheet As Worksheet, auxRow As Long, summarySheet As Worksheet
    Dim increment As Long, SMR As String, prevSMR As String, firstNO As Integer, lastNO As Integer, k As Long
    
    Set summarySheet = Worksheets("Summary")
    lastRow = summarySheet.Columns("A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row 'last row on Summary sheet
    firstRowToCopyData = 7
    increment = 7
    firstNO = 8
    lastNO = 10
    
    For No = firstNO To lastNO
        k = 0 'we use this varible to count unique SMR values
        For i = 2 To lastRow
            If summarySheet.Cells(i, "A") = No Then
                
                SMR = summarySheet.Cells(i, "B")
                Set NOSheet = Worksheets(CStr(No)) 'assuming sheets 8,9,10,etc already exists
                auxRow = NOSheet.Columns("C").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row 'last row on NOSheet
                If auxRow > 1 Then 'if there is existing data in NOSheet
                    prevSMR = NOSheet.Cells(auxRow, "B")
                    If prevSMR = SMR Then 'if consecutive same SMR value
                        auxRow = auxRow + 1
                    Else
                        k = k + 1
                        auxRow = increment * k 'auxRow=7,14,21...
                    End If
                ElseIf auxRow = 1 Then
                    k = k + 1
                    auxRow = firstRowToCopyData 'same than increment*k because firstRowToCopyData=increment
                End If
                
                NOSheet.Cells(auxRow, "A") = No
                NOSheet.Cells(auxRow, "B") = SMR
                NOSheet.Cells(auxRow, "C") = summarySheet.Cells(i, "C")
                NOSheet.Cells(auxRow, "D") = summarySheet.Cells(i, "D")
                NOSheet.Cells(auxRow, "E") = summarySheet.Cells(i, "E")
            End If
        Next i
    Next No
End Sub

Result

VBA Copy and Paste Data with Matching Sheet Name and Multiple Criteria

1 Answers