VBA, Copy component & functionality and then copy it's design & change Type

[maslam15]

First of all I want to say I am thankful and grateful for your help. I need help creating below macro for excel.

I have 3 sheets called 2. Change List, 3. Function List & 5. DRBFM Sheet. On sheet 2 & 3 the data starts from row 3 & on sheet 5 data should start from row 10 Column B.

On Sheet 3. Function List data starts from row there and it has one component and a function listed. Note that the component number could repeat but function will not. I want to copy the component and the function listed from column A & B to be copied unto Sheet 5.DRBFM Sheet on starting from row 10 unto column B & C. Then I want to go to sheet 2.Change List look up by the component name in row B copy everything that is in C, D & E and paste it next to the copied component name and function in column C, D & E in sheet 5.BDRFM and I want it to repeat for each function and component listed in sheet 3. Function List. If the component number & function is already listed in sheet 5.DRBFM do not repeat. In Sheet 5.DRBFM it is possible for design type & change type to repeat in multiple rows based on the component. In that case can you please merge the component and function cell based on how many times design & type repeated? I have added images of my excel as reference. I have created 5. DRBFM Sheet as an example on how it should look like. Once again I am thankful for all of your help. If you have any questions, please let me know

 

[Zot]

In the beginning you will have these two sheets with items?
1) Change Comparison List
2) Function List

The DRBFM sheet is blanks with just headers?

 

[maslam15]

In beginning yes I'll have 2 sheets with Items. The DRBFM sheet will be blank with just headers.

 

[Zot]

I'm still trying to understand more:
In Comparison List you have 2 x 106265 with different Base Design, New Design and Change Type combinations.
In Function List you also have 2 x 106265 with different functions.

Therefore, if I found a Component match between Comparison List and Function List, how do I handle the columns C, D and E. How do I copy column C, D and E from Comparison List to Function List? Which one to copy and which one to ignore?

 

[maslam15]

If the component number in Function List is listed in the Change list, then for that component number I want to copy each cell in the same row on column C, D & E into sheet DRBFM Sheet. Since 10625 repeats twice I want to copy both rows.

 

[Zot]

You have

Change List Comparison.xlsx
	A	B	C	D	E
1	Change Comparison List
2	Change Number	Component	Base Design	New Design	Change Type
3	1	106265	Without core out	With core out	Geometry
4	2	106265	Material: AL 6061	Material: AL A383	Material
5	7	106266	Test Change 3	Test Change 3	New Design
Sheet2

Change List Comparison.xlsx
	A	B
1	Function List
2	Component	Functions
3	106265	connect roller
4	106265	Provide threaded holes
5	106266	Test Function 3
Sheet3

I suggest that you use XL2BB to copy and paste like this. This was helpers out there no need to retype/recreate your sheets.

Looking at your sample above, you have 2 x 106265 in both Change and Function List. The result can expand to become 4 lines in you want to copy Change in to Function List like below. Is this what you meant?

Change List Comparison.xlsx
	A	B	C	D	E
1	Function List
2	Component	Functions	Base Design	New Design	Change Type
3	106265	connect roller	Without core out	With core out	Geometry
4	106265	connect roller	Material: AL 6061	Material: AL A383	Material
5	106265	Provide threaded holes	Without core out	With core out	Geometry
6	106265	Provide threaded holes	Material: AL 6061	Material: AL A383	Material
Sheet6

This also means that on Sheet5, you need to compare both Component and Function, not just Component, to check for existances.

 

[maslam15]

The way you have the Change List comparison sheet is perfect. 106265 is listed twice with 2 different functions so it is repeated 4 times total. 106266 is listed one time and only one function is listed so I will be listed only 1 time.

 

[maslam15]

I think it would be easier to make 2 pivot tables and merging them together. I can show you where to drag the component function etc. I'll just need help with the VBA portion of it. I can try to automate PivotTable and record macro and then perhaps post any questions here if that will be easier?
Thank you,

 

[Zot]

On long weekend from Friday and back in office only on Tuesday. My working sample is in office.

 

[Zot]

Looks like no one has yet to reply to this. I was more away from office and was extremely busy when in office. If you have not find a solution for this, try these codes. I have separated the code into 3 subs but they can be combined.

Sub Test()

Dim m As Long, n As Long
Dim nList As Long, nFunc As Long
Dim eList As Long, eFunc As Long
Dim strRange As String, strData As String
Dim str1 As String, str2 As String, str3 As String
Dim rcell As Range, ccell As Range, rngFunc As Range, rngFound As Range
Dim rngCol As Range, rngMerge As Range
Dim key As Variant, ArryData() As Variant
Dim wsList As Worksheet, wsFunc As Worksheet, wsDRBFM As Worksheet
Dim dictFunc As Object
Dim AddLine As Boolean

Set dictFunc = CreateObject("Scripting.Dictionary")
Set wsList = ActiveWorkbook.Sheets("Sheet2")
Set wsFunc = ActiveWorkbook.Sheets("Sheet3")
Set wsDRBFM = ActiveWorkbook.Sheets("Sheet5")

Application.ScreenUpdating = False

' Find End of List
eList = wsList.Cells(Rows.Count, "A").End(xlUp).Row
For nList = 3 To eList
    eFunc = wsFunc.Cells(Rows.Count, "A").End(xlUp).Row
    Set rngFunc = wsFunc.Range("B3", wsFunc.Cells(Rows.Count, "B").End(xlUp))
    
    ' Register wsFunc data and rows in dictFunc
    dictFunc.RemoveAll
    For nFunc = 3 To eFunc
        strData = wsFunc.Range("A" & nFunc) & "," & wsFunc.Range("B" & nFunc)
        If Not Len(wsFunc.Range("C" & nFunc)) = 0 Then
            strData = strData & "," & wsFunc.Range("C" & nFunc) & "," & wsFunc.Range("D" & nFunc) & "," & wsFunc.Range("E" & nFunc)
        End If
        If Not dictFunc.Exists(strData) Then
            dictFunc.Add strData, nFunc
        Else
            dictFunc(strData) = nFunc
        End If
    Next
    
    For n = eFunc To 3 Step -1
        If wsFunc.Range("A" & n) = wsList.Range("B" & nList) Then
            strData = wsFunc.Range("A" & n) & "," & wsFunc.Range("B" & n)
            str1 = strData & "," & wsList.Range("C" & nList)
            str2 = strData & "," & wsList.Range("C" & nList) & "," & wsList.Range("D" & nList)
            str3 = strData & "," & wsList.Range("C" & nList) & "," & wsList.Range("D" & nList) & "," & wsList.Range("E" & nList)
            If dictFunc.Exists(str3) Then
                m = dictFunc(str3)
            ElseIf dictFunc.Exists(strData) Then
                m = dictFunc(strData)
                wsList.Range("C" & nList, "E" & nList).Copy
                wsFunc.Range("C" & m).PasteSpecial (xlPasteAllExceptBorders)
            Else
                strfunc = strData & "," & wsList.Range("C" & nFunc) & "," & wsList.Range("D" & nFunc) & "," & wsList.Range("E" & nFunc)
                If str3 Like strfunc Or str2 Like strfunc Or strData Like strfunc Then
                    If Len(wsFunc.Range("C" & nFunc)) = 0 Then
                        m = n + 1
                    Else
                        m = dictFunc(str3) + 1
                    End If
                    wsFunc.Range("A" & m).EntireRow.Insert
                    wsFunc.Range("A" & m - 1, "B" & m - 1).Copy wsFunc.Range("A" & m)
                    wsList.Range("C" & nList, "E" & nList).Copy
                    wsFunc.Range("C" & m).PasteSpecial (xlPasteAllExceptBorders)
                End If
            End If
            strRange = "A" & m & ":E" & m
            ArryData = Application.WorksheetFunction.Index(wsFunc.Range(strRange).Value, 1, 0)
            Call DRBFM(ArryData)
        End If
    Next
Next
Set rngMerge = wsDRBFM.Range("B8", wsDRBFM.Cells(Rows.Count, "C").End(xlUp))
Call MergeCells(rngMerge)

Application.ScreenUpdating = True

End Sub

Sub DRBFM(arry() As Variant)

Dim rowNew As Long
Dim rngComp As Range, rngFunc As Range
Dim rngBaseD As Range, rngNewD As Range
Dim wsDRBFM As Worksheet

Set wsDRBFM = ActiveWorkbook.Sheets("Sheet5")

rowNew = wsDRBFM.Cells(Rows.Count, "B").End(xlUp).Row + 1
With wsDRBFM
    .Range("B" & rowNew) = arry(1)
    .Range("C" & rowNew) = arry(2)
    .Range("D" & rowNew) = arry(3)
    .Range("E" & rowNew) = arry(4)
    .Range("F" & rowNew) = arry(5)
End With

Set rngComp = wsDRBFM.Range("B8", wsDRBFM.Cells(Rows.Count, "B").End(xlUp))
Set rngFunc = wsDRBFM.Range("C8", wsDRBFM.Cells(Rows.Count, "C").End(xlUp))
Set rngBaseD = wsDRBFM.Range("D8", wsDRBFM.Cells(Rows.Count, "D").End(xlUp))
Set rngNewD = wsDRBFM.Range("E8", wsDRBFM.Cells(Rows.Count, "E").End(xlUp))

With wsDRBFM.Sort
    .SortFields.Clear
    .SortFields.Add key:=rngComp, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SortFields.Add key:=rngFunc, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SortFields.Add key:=rngBaseD, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SortFields.Add key:=rngNewD, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SetRange Range("A7:F29")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

End Sub

Sub MergeCells(rng As Range)

Dim cell As Range

Application.DisplayAlerts = False
MergeCells:
For Each cell In rng
    If cell.Value = cell.Offset(1, 0).Value And cell.Value <> "" Then
        Range(cell, cell.Offset(1, 0)).Merge
        Range(cell, cell.Offset(1, 0)).HorizontalAlignment = xlCenter
        Range(cell, cell.Offset(1, 0)).VerticalAlignment = xlCenter
        GoTo MergeCells
    End If
Next

End Sub