Adding a Horizontal Loop In a Vertical Loop

DataBlake

Well-known Member
Joined
Jan 26, 2015
Messages
781
Office Version
  1. 2016
Platform
  1. Windows
So i have this code that duplicates rows from a sheet (the active sheet) if it meets certain criteria and replaces the first cell with a new text string.
It does exactly what i need it to do vertically.
For each duplicate row i want the range highlighted in red to be replaced by each corresponding
Code:
Worksheets("TitleHelper").Range("D" & j)
but i can only get one of the "D" values when i need all 4 (or less)
examples provided below code

Code:
Sub parentCHILD()
Dim childROWmax    As Long
Dim parentROWmax   As Long
Dim childCOL       As Long
Dim i              As Long
Dim j              As Long
Dim z              As Long
Dim v              As Long
Dim parentPATTERN  As Range
Dim parentPATTERN2 As Range
Dim parentWEIGHT   As Range
Dim childPATTERN   As Range
Dim oMAX           As Range
Dim oMIN           As Range
Dim childCODE      As Range
Dim parentPART     As Range
Dim newPART        As String
Dim newSHEET       As Worksheet
Dim oldSHEET       As Worksheet

Set oldSHEET = ActiveSheet
parentROWmax = oldSHEET.Cells(Rows.Count, 1).End(xlUp).Row
Set newSHEET = ThisWorkbook.Sheets.Add(After:= _
             ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    newSHEET.Name = "Result"
childROWmax = Sheets("TitleHelper").Cells(Rows.Count, 1).End(xlUp).Row
MHTROWmax = newSHEET.Cells(Rows.Count, 1).End(xlUp).Row
    
    
    For i = 2 To parentROWmax
        z = 1
    
        'Increment Result sheet row
        MHTROWmax = MHTROWmax + 1

        'get Old row info for comparison
           Set parentPATTERN = oldSHEET.Range("J" & i)
           Set parentPATTERN2 = oldSHEET.Range("K" & i)
           Set parentWEIGHT = oldSHEET.Range("H" & i)
           Set parentPART = oldSHEET.Range("A" & i)
           Set lastCol = oldSHEET.Range("A1").SpecialCells(xlCellTypeLastCell).Column
           
        'Write a row to Result Table
        oldSHEET.Rows(i).Copy newSHEET.Rows(MHTROWmax)

        For j = 2 To childROWmax

            'get TitleHelper row info for comparison
            Set childPATTERN = Worksheets("TitleHelper").Range("A" & j)
            Set oMAX = Worksheets("TitleHelper").Range("C" & j)
            Set oMIN = Worksheets("TitleHelper").Range("B" & j)
            Set childCODE = Worksheets("TitleHelper").Range("F" & j)
            newPART = parentPART & "*" & childCODE
            
            
            'Perform if/then
            If (parentPATTERN = childPATTERN _
                Or parentPATTERN2 = childPATTERN) _
               And parentWEIGHT <= oMAX _
               And parentWEIGHT >= oMIN _
               And z < 5 Then
                   z = z + 1
                   
                'Increment Result sheet row
                MHTROWmax = MHTROWmax + 1

                
                'Criteria is met, write a row to Result Table
                oldSHEET.Rows(i).Copy newSHEET.Rows(MHTROWmax)
                newSHEET.Cells(MHTROWmax, 1) = newPART
                [I][U][COLOR=#ff0000][B]newSHEET.Cells(MHTROWmax, lastCOL + 1) =[/B][/COLOR][/U][/I]
            End If
        Next j

    Next i
End Sub

Here is a working example with excel 2016
https://drive.google.com/file/d/1m_puDtzCMmRMRb_h4kCqEPvpUAJQSSg_/view?usp=sharing

run the macro and it will create a result page, but i need it to produce "Expected Result" sheet
hopefully its easy to understand as i tried to keep the code as clean as possible
it doesn't matter if the "D" values are in one cell of multiple as long as they are in each duplicated row as shown.
 

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.

Forum statistics

Threads
1,214,649
Messages
6,120,732
Members
448,987
Latest member
marion_davis

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top