Loop Through Validation List and Copy Values Given for Each Item

[mjgcancio]

Hi all.

I've been struggling with VBA (my knowledge is a bit short for this) and I could use some help.

I need that the current macro can run through all items of the data validation list "Data List" in Sheet1, and then item by item, copy the dynamic values in "Rows to Copy" to the correspondent row in "Rows to Paste".
Note: the formulas in "Rows to Copy" are:

Column D =(VLOOKUP(B2,H3:J28,2,FALSE))*(VLOOKUP(B2,H3:J28,3,FALSE))
Column E =(VLOOKUP(B2,H3:J28,2,FALSE))*(VLOOKUP(B2,H3:J28,3,FALSE))*D3
Column F =(VLOOKUP(B2,H3:J28,2,FALSE))*(VLOOKUP(B2,H3:J28,3,FALSE))*E33

So far I, and after some research and trial and error, I could only make it copy one by one, but repeating all rows and I'm stuck in here, through this code:

Sub FillRows()
      
Dim rng As Range
Dim dataValidationArray As Variant
Dim i As Integer
Dim rows As Integer


'Set the cell which contains the Data Validation list
Set rng = ActiveSheet.Range("B2")

'If Data Validation list is not a range, ignore errors
On Error Resume Next


'Create an array from the Data Validation formula, without creating
'a multi-dimensional array from the range
rows = Range(Replace(rng.Validation.Formula1, "=", "")).rows.Count
ReDim dataValidationArray(1 To rows)

For i = 1 To rows
    dataValidationArray(i) = _
        Range(Replace(rng.Validation.Formula1, "=", "")).Cells(i, 1)
Next i


'If not a range, then try splitting a string
If Err.Number <> 0 Then
    Err.Clear
    dataValidationArray = Split(rng.Validation.Formula1, ",")
End If


'Some other error has occured so exit sub
If Err.Number <> 0 Then Exit Sub

'Reinstate error checking
On Error GoTo 0

    'Loop through all the values in the Data Validation Array
    For i = LBound(dataValidationArray) To UBound(dataValidationArray)

        'Change the value in the data validation cell
        rng.Value = dataValidationArray(i)

        'Force the sheet to recalculate
        Application.Calculate

''''''''''''''''''''''''''''''''''''''''''
'Start the code here''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''

        Dim z As Range
        
        For Each z In Range("K3:M28").rows

                Range("D3").Copy
                z.Cells(1).PasteSpecial Paste:=xlPasteValues
                Range("E3").Copy
                z.Cells(2).PasteSpecial Paste:=xlPasteValues
                Range("F3").Copy
                z.Cells(3).PasteSpecial Paste:=xlPasteValues

         Next
        
''''''''''''''''''''''''''''''''''''''''''
'End code here''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''

    Next i


'-----------------------------------------------------------------

  MsgBox ("Done")
 
End Sub

Thanks in advanced,

MC

 

[mjgcancio]

Ok so I found the solution.

Hope it might help someone.

Sub Iteration_Loop()
Dim Rng As Range
Dim c As Range
Dim DestRow As Long

     'Set Rng to the list of values in the validation list
'Set Rng = Sheets("Analysis").Range(Sheets("Analysis").Range("B6").Validation.Formula1)
Set Rng = ActiveSheet.Range(ActiveSheet.Range("B2").Validation.Formula1)
DestRow = 0

     For Each c In Rng.Cells
     'Sheets("Analysis").Range("B6").Value = c.Value
     ActiveSheet.Range("B2").Value = c.Value
     Application.Calculate
     'Sheets("Analysis").Range("B10:N25").Copy
     ActiveSheet.Range("D3:F3").Copy
     'Sheets("Output Sheet").Range("C" & DestRow + 5).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
     ActiveSheet.Range("K" & DestRow + 3).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
     DestRow = DestRow + 1
     Next c
    
     Range("B2").Select

End Sub

Best regards
MC