Search for name in one sheet, copy, paste in another sheet and insert new row on condition

Question

I'm struggling quite a while with possible solutions, but i couldn't find something similar online, and im could use some help. Screenshot example and workbook sample in links under question. I asked same question on different forum, but no answers... https://www.mrexcel.com/board/threads/find-copy-insert-row-on-condition-with-cell-merge-and-formula-copy.1178634/

I have 3 worksheets, ForDelivery, Document1 and Document2. From document sheets i print first page or send it via email, i want to fill specific cells in document sheets 1 and 2 (range"G19:K") with values from ForDelivery sheets (values are in range"B2:F".

In sheets Document1 and Document2 i have table template, column "B" in both sheets contain product names, i would need macro that would search for those names in sheet ForDelivery and if name is found in column "A" then copy all values from range "B:F" from row where name was found into row in sheet where name is, column range "G:K". I menage to complete this job with XLOOKUP fuction BUT problem happends when there is more then one product name in column "A" (number can vary from 2 to 8). That function can't handle, but i hope macro can. So for every same name i need to insert new row under orginal row, copy forumlas from above, and paste values to range "G:K". I made a code that will merge cells in columns A,B, and F, to prevent duplicates values. So basically, if there are 3 same names in column "A" in ForDelivery sheet insert 2 row (2 because there is already one row existing) in Document 1 or 2 sheet where name is found, and paste data from range B:F into range G:K. Thanks in advance.

ScreenShot: https://ibb.co/sFh5dRY Workbook sample here: https://easyupload.io/4f7cq2

If its of some use, here is the code i use for merging cells in columns

Sub macro1()
Dim lngLastRow As String
Dim lastRow As Long
Dim lastcolumn As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
lastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
lastcolumn = ActiveSheet.UsedRange.Column - 1 + ActiveSheet.UsedRange.Columns.Count

ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Key:=Range(Cells(19, 1), Cells(lastRow, 1)), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

With ActiveSheet.Sort
.SetRange Range(Cells(19, 1), Cells(lastRow, lastcolumn))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

For i = lastRow To 19 Step -1

If Cells(i, 1).Value = Cells(i - 1, 1).Value Then
Range(Cells(i, 1), Cells(i - 1, 1)).Select
Selection.Merge
Range(Cells(i, 2), Cells(i - 1, 2)).Select
Selection.Merge
Range(Cells(i, 3), Cells(i - 1, 3)).Select
Selection.Merge
Range(Cells(i, 6), Cells(i - 1, 6)).Select
Selection.Merge

End If

Next
Application.ScreenUpdating = True

End Sub

Gokhan Aycan Gokhan Aycan · Accepted Answer · 2021-08-09T21:29:46

You can try this code, I added comments so you can have an idea what's going on. Codename is given inside VBA for any sheet, they are good if your sheets will not be deleted by anyone. If not change them to your sheet names as usual.

Note: I can't seem to see the comments in a different color in the preview. Also, didn't test the formula part. Sorry if I missed something.

Public Sub Populate_Document1()
    
    Dim i As Long, no_item_doc1 As Long, currentrow_doc1 As Long
    Dim rngDelivery As Range
    Dim cCell_Doc1 As Range
    Dim cCell_Delivery As Range
    
    Dim rngDoc1 As Range
    Dim arrDoc1 As Variant
    Dim lastrow_doc1 As Long
    
    ' Find last row of Document1 (Codename set as doc1 in VBA Editor)
    ' doc1 = sheets("Document1")
    ' delivery = sheets("ForDelivery")
    lastrow_doc1 = doc1.Cells(18, 2).End(xlDown).Row
    
    Set rngDoc1 = doc1.Range("B19:B" & lastrow_doc1)
    
    ' Assign rngDoc1 values to an array arrDoc1
    ReDim arrDoc1(1 To rngDoc1.Rows.Count, 1 To 1) As String
    arrDoc1 = rngDoc1.Value ' arrays normally start with index 0, but 1 if we assign from a range
    
    ' Set rngDelivery to items list on ForDelivery Sheet
    ' Can be done in one line, but easier to read like this
    Set rngDelivery = delivery.Range("A1").CurrentRegion
    Set rngDelivery = rngDelivery.Offset(1, 0).Resize(rngDelivery.Rows.Count - 1, 1)
    
    currentrow_doc1 = 19 ' will update this if we insert any lines due to duplicates
    
    For i = 19 To lastrow_doc1
        no_item_doc1 = 0 ' reset to 0, number of items found on delivery sheet for the item in question in doc1
        For Each cCell_Delivery In rngDelivery
            If cCell_Delivery.Value = arrDoc1(i - 18, 1) Then
                If no_item_doc1 = 0 Then
                    no_item_doc1 = 1
                    cCell_Delivery.Offset(0, 1).Resize(1, 5).Copy doc1.Range("G" & currentrow_doc1)
                Else
                    ' increase currentrow since a duplicate is found
                    currentrow_doc1 = currentrow_doc1 + 1
                    
                    ' Insert a row
                    doc1.Rows(currentrow_doc1).Insert
                    
                    ' copy the B-F columns from delivery sheet
                    cCell_Delivery.Offset(0, 1).Resize(1, 5).Copy doc1.Range("G" & currentrow_doc1)
                    
                    ' copy A-F columns of duplicate item from 1 row above
                    doc1.Range("A" & currentrow_doc1 - 1 & ":F" & currentrow_doc1 - 1).Copy doc1.Range("A" & currentrow_doc1 & ":F" & currentrow_doc1)
                    
                    ' copy the formulas from 1 row above
                    doc1.Range("D" & currentrow_doc1 - 1 & ":E" & currentrow_doc1 - 1).Copy
                    doc1.Range("D" & currentrow_doc1 & ":E" & currentrow_doc1).PasteSpecial Paste:=xlPasteFormulasAndNumberFormats
                    
                    ' set font color to easily distinguish duplicates, can remove later if you want
                    doc1.Range("A" & currentrow_doc1 & ":F" & currentrow_doc1).Font.Color = rgbRed
                End If
            End If
        Next cCell_Delivery
        
        ' increase currentrow by 1 since we are moving on to the next item on doc1
        currentrow_doc1 = currentrow_doc1 + 1
    Next i
    
    ' clean up set objects, not necessary here but good practice
    Set rngDoc1 = Nothing
    Set rngDelivery = Nothing
    
End Sub

Search for name in one sheet, copy, paste in another sheet and insert new row on condition

1 Answers