Consolidated Report - VBA Copy from one sheet and insert copied cells (shift cells down) in another sheet respecting the main column

[BorisTheCat84]

Hi Team,
I'm looking to run a VBA code from Sheet3 (Consolidated Report) that will check ID1 in sheet2 and when found it has to copy from Sheet2 ID2,Owner,Role,Role Status, and Role Title and insert copied cells (Cells shift down) respecting the cell in column A as the copied data starts from column B but the cell in column A should shift down as well // If it doesn't find ID1 in sheet2 then skip to the other.
In the current example, we have a total of 5 rows but actually the script should detect the last row and stop on it, this report would have in the future x number of rows.
Both Sheet2 and Consolidated Report are in the same workbook:

Sheet2:

Mr. Excel.xls
	A	B	C	D	E	F
1	Up and Coming Tournament
2	ID1	ID2	Owner	Role	Role Status	Role Title
3	S001	TK001	Boris	Clown	NEW	Clown Ready
4	S002	TK002	Kiera	Jungler	NEW	Jungler Sleepy
5	S003	TK003	Tarta	Flyer	NEW	Flyer on the fly
6			Anton	Spy	Approved	Spy mode activated
7			Caro	Asher	Approved	Asher is Ashing
8			Sinna	Spy	pending	Spy mode activated
9	S004	TK004	Victor	Clown	Approved	Clown Ready
10			Caro	Asher	Approved	Asher is Ashing
11		TK005	Arsene	Clown	pending	Clown Ready
12	S006	TK006	Boris	Asher	pending	Asher is Ashing
Sheet2

Consolidated Report:

Mr. Excel.xls
	A	B	C	D	E	F
1	Consolidated Report
2	ID1	ID2	Owner	Role	Role Status	Role Title
3	S001
4	S004
5	S003
6	S005
7	S006
8	S002
Consolidated Report

Expected Result after running the VBA Code on Sheet3 (Consolidated Report):

Consolidated Report
ID1	ID2	Owner	Role	Role Status	Role Title
S001	TK001	Boris	Clown	NEW	Clown Ready
S004	TK004	Victor	Clown	Approved	Clown Ready
		Caro	Asher	Approved	Asher is Ashing
S003	TK003	Tarta	Flyer	NEW	Flyer on the fly
		Anton	Spy	Approved	Spy mode activated
		Caro	Asher	Approved	Asher is Ashing
		Sinna	Spy	pending	Spy mode activated
S005
S006	TK006	Boris	Asher	pending	Asher is Ashing
S002	TK002	Kiera	Jungler	NEW	Jungler Sleepy

Your help will be truly appreciated

 

[kanadaaa]

Try this in a standard module:

Sub TransferDataBasedOnCriteria()
    Dim sh2 As Worksheet, lr As Long, i As Long, fnd As Range, cnt As Long
    
    Set sh2 = Worksheets("Sheet2")
    Application.ScreenUpdating = False
    
    With Worksheets("Consolidated Report")
        If .Cells(3, "A") = "" Then GoTo errHandler
        lr = sh2.Range("A:F").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        For i = .Cells(Rows.Count, "A").End(xlUp).Row To 3 Step -1
            Set fnd = Range(sh2.Cells(3, "A"), sh2.Cells(lr, "A")).Find(.Cells(i, "A").Value, , xlValues, xlWhole)
            If Not fnd Is Nothing Then
                cnt = fnd.MergeArea.Count
                If cnt <> 1 Then
                    .Rows(.Cells(i, "A").Offset(1).Row & ":" & .Cells(i, "A").Offset(1).Row + cnt - 2).Insert (xlDown)
                End If
                fnd.MergeArea.Resize(, 6).Copy .Cells(i, "A")
            End If
            Set fnd = Nothing
        Next i
    End With
    
    Application.ScreenUpdating = True
    MsgBox "Done."
    
Exit Sub
errHandler:
    MsgBox "No IDs are in column A on Consolidated Report.", vbExclamation, "Error"
    
End Sub

 

[BorisTheCat84]

Try this in a standard module:

Sub TransferDataBasedOnCriteria()
    Dim sh2 As Worksheet, lr As Long, i As Long, fnd As Range, cnt As Long
   
    Set sh2 = Worksheets("Sheet2")
    Application.ScreenUpdating = False
   
    With Worksheets("Consolidated Report")
        If .Cells(3, "A") = "" Then GoTo errHandler
        lr = sh2.Range("A:F").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        For i = .Cells(Rows.Count, "A").End(xlUp).Row To 3 Step -1
            Set fnd = Range(sh2.Cells(3, "A"), sh2.Cells(lr, "A")).Find(.Cells(i, "A").Value, , xlValues, xlWhole)
            If Not fnd Is Nothing Then
                cnt = fnd.MergeArea.Count
                If cnt <> 1 Then
                    .Rows(.Cells(i, "A").Offset(1).Row & ":" & .Cells(i, "A").Offset(1).Row + cnt - 2).Insert (xlDown)
                End If
                fnd.MergeArea.Resize(, 6).Copy .Cells(i, "A")
            End If
            Set fnd = Nothing
        Next i
    End With
   
    Application.ScreenUpdating = True
    MsgBox "Done."
   
Exit Sub
errHandler:
    MsgBox "No IDs are in column A on Consolidated Report.", vbExclamation, "Error"
   
End Sub

Works like a charm, the only request remains if there is an empty cell in Column A in "Consolidated Report" (let's say between row 6 and row 7), it has to skip to the other ID1 and not copy row 11 in Sheet2 // can we adjust accordingly? Thanks a lot!

 

[kanadaaa]

Here:

Sub TransferDataBasedOnCriteria()
    Dim sh2 As Worksheet, lr As Long, i As Long, fnd As Range, cnt As Long
    
    Set sh2 = Worksheets("Sheet2")
    Application.ScreenUpdating = False
    
    With Worksheets("Consolidated Report")
        If .Cells(3, "A") = "" Then GoTo errHandler
        lr = sh2.Range("A:F").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        For i = .Cells(Rows.Count, "A").End(xlUp).Row To 3 Step -1
            If .Cells(i, "A") = "" Then GoTo NextIteration
            Set fnd = Range(sh2.Cells(3, "A"), sh2.Cells(lr, "A")).Find(.Cells(i, "A").Value, , xlValues, xlWhole)
            If Not fnd Is Nothing Then
                cnt = fnd.MergeArea.Count
                If cnt <> 1 Then
                    .Rows(.Cells(i, "A").Offset(1).Row & ":" & .Cells(i, "A").Offset(1).Row + cnt - 2).Insert (xlDown)
                End If
                fnd.MergeArea.Resize(, 6).Copy .Cells(i, "A")
            Else
                GoTo NextIteration
            End If
            Set fnd = Nothing
NextIteration:
        Next i
    End With
    
    Application.ScreenUpdating = True
    MsgBox "Done."
    
Exit Sub
errHandler:
    MsgBox "No IDs are in column A on Consolidated Report.", vbExclamation, "Error"
    
End Sub

 

[kanadaaa]

And this may come in handy when you need to reset the table on Consolidated Report:

Sub ClearTable()
    Dim i As Long
    With Worksheets("Consolidated Report")
        With .Range("A3:F" & Rows.Count)
            .UnMerge
            .ClearContents
        End With
        'Comment out the below 3 lines if you don't need to fill ID1
        For i = 3 To 8
            .Cells(i, "A") = Choose(i, , , "S001", "S004", "S003", "S005", "S006", "S002")
        Next i
    End With
End Sub