Find, Copy & Insert row on condition with cell merge and formula copy.

[mir994stan]

Greetings to everyone,
I completed my workbook project, all works great and autonomous as expected, but i would like to add one more feature to it. I was looking whole day on forums and youtube, but coludn t find anything similar, i do some VBA but, i rly can t handle this, and i could use some help. I tried with xlookup, match, index but it can t be solved with functions... Its little complicated question but i will try to explain it good.
I will put sample workbook with data and document tamplate, i also recored a macro while i was manualy doing this job, just for preview of whats required.
Sample WB: Link to sample Workbook
I have 3 sheets, "ForDelivery", "Document1" and "Document2". Sheet "ForDelivery" contain shipment data in range "A:F" in column "A" are product names and in column "B" are serial numbers, so in range "B:F" are informations for that product.
Document sheets, 1 and 2 needs to be populated with corensponding values from "For delivery" sheet in column range "G:K" starting from row 19 and down. So i need a macro that will search for product name in document sheets, column B is where names are, and if there is a match, copy values from range "B:F" in Sheet "ForDelivery" to row in document sheet where name was found in ragne "G:K", so values from column B goes to column G, C to H, and etc..

I made this work with XLookup, but problem where function can t work is when i have more then one serial number for one product name. Column "B" in Sheet "ForDelivery" contain serial numbers for each product, main purpose of macro is to insert new row under existing row if there are more then one serial number, copy formulas from above in columns D and E, and if possible to merge cells in columns A,B,C and F with cells in new row.

As always, thanks in advance.


Code i made with macro recored

Sub COPY_INSERT_ROWS()
'
' Code added for faster run

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


    Sheets("ForDelivery").Select
    Range("B19:F19").Select
    Selection.Copy
    Sheets("Document1").Select
    Range("G34:K34").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("ForDelivery").Select
    Range("B2:F2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Document1").Select
    Range("G24:K24").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Rows("24:24").Select
    Range("B24").Activate
    Application.CutCopyMode = False
    Selection.Copy
    Rows("25:25").Select
    Range("B25").Activate
    Selection.Insert Shift:=xlDown
    Sheets("ForDelivery").Select
    Range("B3:F3").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Document1").Select
    Range("G25:K25").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("F24:F25,C24:C25,B24:B25,A24:A25").Select
    Range("B25").Activate
    Application.CutCopyMode = False
    Selection.Merge
    
    '---------------------------------------
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    
End Sub

 

[mir994stan]

I managed to get working code for merging cells if they are same in, columns A,B,C and F. I only need now macro to insernt new row if there are more then 2 serial number for product...

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(2, 1), Cells(lastRow, 1)), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

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

For i = lastRow To 2 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

 

[mir994stan]

Solved with help from member on stackoverflow. If anyone have simmilar problem here is the code:

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