Copy data set to another sheet and duplicate certain rows based on cell value from table

[onedayatatime]

I’ve really learned a lot from this forum over the last 5 or so years and seem to figure quite a bit out from the expert guidance but this one has me a bit stumped.

I have a worksheet that has about 90 utilized columns and depending on the week the number of rows containing data is that needs to be manipulated is different. Could be 20 rows one day could be 200 the next. Via VBA I’d like to copy my data set to another worksheet but insert duplicated and slightly modified rows depending if a certain criteria is met.

I’ve simplified the data and will use Fruits and cities in my example. A table (I’m open to how it’s formed, horizontally or vertically, etc.) on its own worksheet will list the fruit and the associated subtypes.

I’ve simplified the data but the ask and example below is if a row contains a specific fruit from the defining table i.e. Apple then duplicate that row based on the number of subtypes listed in the table. Then replace the first Apple reference with the first subtype and so on. If 3 subtypes are listed for the fruit then there will be 3 rows each with the unique subtype. If there are 2 subtypes listed then there will be 2 rows with each of those subtypes.

Starting Dataset

Optimized Dataset: here you can see that since there were 3 apple subtypes identified each time apple comes up there would be now 3 rows each. For Pear since two subtypes were defined, two rows are formed with each of those subtypes.

 

[DanteAmor]

Hi and welcome to MrExcel.

The macro involves 3 sheets, sh1 for "fruits" and "subtypes", sh2 for the data and s3 for the results.
Also consider that the data in the sh1 sheets start at A1, sh2 and sh3 start at A8.

Sub copy_and_duplicate_rows()
  Dim a As Variant, b As Variant, c As Variant
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
  Dim dic As Object
  Dim i As Long, j As Long, k As Long, n As Long, nrow As Long, m As Long
  
  'fit the names of the sheets :
  Set sh1 = Sheets("sh1")   '"list the fruit and the associated subtypes"
  Set sh2 = Sheets("sh2")   'Starting Dataset
  Set sh3 = Sheets("sh3")   'Optimized Dataset
  Set dic = CreateObject("Scripting.Dictionary")
  
  With sh1.Range("A1").CurrentRegion
    a = .Value
    n = WorksheetFunction.CountA(.Offset(1, 1))
  End With
  For i = 2 To UBound(a, 1)
    dic(a(i, 1)) = i
  Next
 
  b = sh2.Range("A8", sh2.Range("E" & Rows.Count).End(3)).Value
  ReDim c(1 To UBound(b, 1) + n, 1 To 5)
  For i = 2 To UBound(b, 1)
    If dic.exists(b(i, 2)) Then
      nrow = dic(b(i, 2))
      For k = 2 To UBound(a, 2)
        If a(nrow, k) = "" Then Exit For
        m = m + 1
        For j = 1 To UBound(b, 2)
          c(m, j) = b(i, j)
          If j = 2 Then c(m, j) = a(nrow, k)
        Next
      Next
    Else
      m = m + 1
      For j = 1 To UBound(b, 2)
        c(m, j) = b(i, j)
      Next
    End If
  Next
  
  sh3.Rows("8:" & Rows.Count).ClearContents
  sh3.Range("A8").Resize(m, UBound(c, 2)).Value = c
End Sub

 

[onedayatatime]

Thank you so much for your thoughts and experience on this. My approach was markedly different and likely why I was not successful with my attempt. At first glance this is exactly what I’m looking for, I think you made an absolutely super crack at it! I experienced a couple issues as I ran the code. Initially this was not working for me but I soon came to learn one issue was all my fault. I could not for the life of me figure out why Pears were breaking down into their subtypes but not Apples. Then of course the most obvious culprit was my mistyping Apple on sh1 which included a trailing space at the end which clearly made it different from the dataset. That got solved.

Second I am needing to adjust slightly the sh2.Range as I’m finding the code doesn't work when the last column of the range does not have all filled cells. More specifically if the outside of the range, last column, does not have data at the bottom most cell, it won’t capture those rows because it measures up from the bottom to determine the range. I can correct for that if I reverse the range and use “b = sh2.Range("E8", sh2.Range("A" & Rows.Count).End(3)).Value” – not sure if that has other downstream impacts but that seems to work was successful as currently Column A is always populated.

Two other tweaks I'm realizing I'd like to make,
1) as I’m new to VBA, I’m trying to decipher your steps and add comments so I better understand them, what portion of the script is identifying the variable column that is being evaluated? Currently it is Column “B” but it’s not clear to me what I need to change if I want to alter the evaluation column? Alternatively, rather than hardcoding it, is it possible to make that a variable and identify that on sh2 so if needed it could be changed to Column C or D, or etc.?

2) I'm realizing that i need to separate onto separate sheets some alternate subtypes. I figure i could duplicate the routine for the 2 other worksheets using the same sh2 dataset. What method would you recommend employing to do that?

Set sh1a = Sheets("sh1a") '"list the fruit and the associated subtypes"
Set sh1b = Sheets("sh1b") '"list the fruit and the associated Pests"
Set sh1c = Sheets("sh1c") '"list the fruit and the associated Repair"
Set sh2 = Sheets("sh2") 'Starting Dataset
Set sh3 = Sheets("sh3") 'Optimized Dataset of subtypes
Set sh4 = Sheets("sh4") 'Optimized Dataset of Pests
Set sh5 = Sheets("sh5") 'Optimized Dataset of Repair
Set dic = CreateObject("Scripting.Dictionary")

sh1b

sh1c

-Mark

 

[DanteAmor]

currently Column A is always populated.

Use this:

b = sh2.Range("A8:E" & sh2.Range("A" & Rows.Count).End(3).row).Value

what portion of the script is identifying the variable column that is being evaluated? Currently it is Column “B” but it’s not clear to me what I need to change if I want to alter the evaluation column? Alternatively, rather than hardcoding it, is it possible to make that a variable and identify that on sh2 so if needed it could be changed to Column C or D, or etc.?

In this part it evaluates column "B", i.e. column 2 of the matrix.

    If dic.exists(b(i, 2)) Then
      nrow = dic(b(i, 2))

---
I added some comments

Sub copy_and_duplicate_rows()
  Dim a As Variant, b As Variant, c As Variant
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
  Dim dic As Object
  Dim i As Long, j As Long, k As Long, n As Long, nrow As Long, m As Long
  
  'fit the names of the sheets :
  Set sh1 = Sheets("sh1")   '"list the fruit and the associated subtypes"
  Set sh2 = Sheets("sh2")   'Starting Dataset
  Set sh3 = Sheets("sh3")   'Optimized Dataset
  Set dic = CreateObject("Scripting.Dictionary")
  
  With sh1.Range("A1").CurrentRegion
    a = .Value
    n = WorksheetFunction.CountA(.Offset(1, 1))
  End With

'In this part you create an index for each fruit and store in the index the row number where the fruit is located, so that later you can read the subtypes.
  For i = 2 To UBound(a, 1)
    dic(a(i, 1)) = i
  Next
 
  b = sh2.Range("A8", sh2.Range("E" & Rows.Count).End(3)).Value
  ReDim c(1 To UBound(b, 1) + n, 1 To 5)
  For i = 2 To UBound(b, 1)
    If dic.exists(b(i, 2)) Then
'If the fruit is in the index, then it gets the row number.
      nrow = dic(b(i, 2))
      For k = 2 To UBound(a, 2)
'Add a row for each subtype that the fruit has:
        If a(nrow, k) = "" Then Exit For    'If there are no longer subtypes, it leaves the cycle
        m = m + 1     'Row counter
'Passes the data from array 2 to the output array
        For j = 1 To UBound(b, 2)
          c(m, j) = b(i, j)
          If j = 2 Then c(m, j) = a(nrow, k) 'Put the subtype
        Next
      Next
    Else
      m = m + 1
      For j = 1 To UBound(b, 2)
        c(m, j) = b(i, j)
      Next
    End If
  Next
  
  sh3.Rows("8:" & Rows.Count).ClearContents
  sh3.Range("A8").Resize(m, UBound(c, 2)).Value = c
End Sub

 

[onedayatatime]

Thank you for the additional clarity. I’m trying to debug some issues that are popping up. I’ve noticed that the script works exactly as is and with the very basic sample data set. However if I expand the fruit list by adding just one more Apple subtype or adding to the Pear subtype it seems to error out. With a Run-time error ‘9’: Subscript out of range. Or if I expand the dataset and leave the defining subtypes alone it also errors out with a similar Run-time error ‘9’: Subscript out of range error. The code seems to work for exactly this scenario and limited data but not when it is expanded or altered much. Any thoughts what might fortify it so it might work with more/augmented data?