Loop Through Data Validation List and Copy Values Given By 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, 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, with 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

[snb]

First step to analyze:


Sub M_snb()
MsgBox Join(Evaluate("transpose(" & Mid(Cells(2, 2).Validation.Formula1, 2) & ")"), vbLf)
End Sub

Put this macro into the codemodule of the sheet, not in module 'Macro1'.

[mjgcancio]

First step to analyze:


Sub M_snb()
MsgBox Join(Evaluate("transpose(" & Mid(Cells(2, 2).Validation.Formula1, 2) & ")"), vbLf)
End Sub

Put this macro into de codemodule of the sheet, not in moduel 'Macro1'.

Hi snb and thanks for the response.

I´ve done that and it didn't gave me any message or changes in what the macro should do.
It keeps looping though all the rows but repeats whateaver item is selected in the data validation list throughout the rows, when what I need is:

Select item 1 in Data Validation List - copy values in "Rows To Copy" - to row 1 in "Rows to Paste";
Select item 2 in Data Validation List - copy values in "Rows To Copy" - to row 2 in "Rows to Paste";
Select item 3 in Data Validation List - copy values in "Rows To Copy" - to row 3 in "Rows to Paste";
...

Any ideas?

MC

[snb]

Please do not quote.
You forgot to read the first line I wrote.

[mjgcancio]

I'm sorry snb...
I din't run the code from the page.

Yes it gives the entire items in the Data Validation list.

Any next step?

Thanks

MC

[snb]

Analyzing, analyzing, analyzing


Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$2" Then
sp = Application.Index(Evaluate(Mid(Cells(2, 2).Validation.Formula1, 2)).Resize(, 3), Application.Match(Target, Evaluate(Mid(Cells(2, 2).Validation.Formula1, 2))), 0)
Cells(rows.Count, 11).End(xlUp).Offset(1).Resize(, 3) = Array(sp(1, 2) * sp(1, 3), (sp(1, 2) * sp(1, 3)) ^ 2, (sp(1, 2) * sp(1, 3)) ^ 3)
End If
End Sub

[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

[snb]

Please test & analyze the solution I provided in #6