Excel VBA Iterate through data validation lists and copy range from worksheet to a new worksheet - excel

Question

Option Explicit
Sub LoopThroughValidationList()
Dim lst As Variant
Dim rCl As Range
Dim str As String
Dim iX As Integer
str = Range("B1").Validation.Formula1
On Error GoTo exit_proc:
If Left(str, 1) = "=" Then
str = Right(str, Len(str) - 1)
For Each rCl In Worksheets(Range(str).Parent.Name).Range(str).Cells
Range("B1").Value = rCl.Value
Next rCl
Else
lst = Split(str, ",")
For iX = 0 To UBound(lst)
Range("B1").Value = lst(iX)
Next iX
End If
Exit Sub
exit_proc:
MsgBox "No validation list ", vbCritical, "Error"
End Sub
I am tring to iterate through two data validation lists and copy a range in sheet1 to sheet2 for every iteration. This code iterates through one data validation drop down and doesn't copy the range I want in sheet1.
Change data validation list1 to first item in list
Change data validation list2 to first item in list
Copy range from sheet1 to sheet2, first item in list + first item in list + copied range
Repeat
UPDATE 2018-07-27:
Here are the formulas for my data validation list ='A. Dashboard2'!$B$1:$V$1, ='A. Dashboard'!$B$1:$V$1. And also =OFFSET('A. Dashboard'!$A$1;1;MATCH($F$4;'A. Dashboard'!$A$1:$V$1;0)-1;COUNTA(OFFSET('A. Dashboard'!$A$1;1;MATCH($F$4;'A. Dashboard'!$A$1:$V$1;0)-1;55;1));1)

Answer 1

Untested, written on mobile. See if it works and whether it does what you want.
Code expects that validation list 1 will always begin with an = sign and will be a reference to a range -- and that validation list 2 is a ; delimited list.
Code expects sheets called Dashboard and Result to already exist.
Code will attempt to copy the various ranges (from Dashboard sheet) to a new row on the Result sheet for each item in the validation lists.
Option Explicit
Sub LoopThroughValidationLists()
With thisworkbook
Dim resultsRange as range 'First cell to output to'
Set resultsRange = . worksheets("Result").range("A1")
with .worksheets("Dashboard")
dim list1range as range
set list1range = .range("G3")
dim list2range as range
set list2range = .range("W3")
dim rangeToCopy1 as range
set rangeToCopy1 = .range("K9:K40")
dim rangeToCopy2 as range
set rangeToCopy2 = .range("Z9:Z40")
end with
end with
dim list1formula as string
on error resume next
list1formula = list1range.Validation.Formula1
on error goto 0
dim list2formula as string
on error resume next
list2formula = list2range.Validation.Formula1
on error goto 0
if Len(list1formula) = 0 then
MsgBox("Validation list1 not detected.")
exit sub
elseif ASC(list1formula) <> 61 then
MsgBox("Expected list1 to begin with '='")
exit sub
elseif instrrev(list1formula,"!",-1,vbbinarycompare) > 0 then
List1formula = mid$(list1formula,instrrev(list1formula,"!",-1,vbbinarycompare)+1)
List1formula = replace(list1formula,"$",vbnullstring,1,vbbinarycompare)
End if
if Len(list2formula) = 0 then
MsgBox("Validation list2 not detected.")
exit sub
end if
dim list1items as range
on error resume next
set list1items = thisworkbook.worksheets("A. Dashboard").range(mid$(list1formula,2))
on error goto 0
if list1items is nothing then
MsgBox("Expected validation list1 to refer to a range:" & VBnewline & vbnewline & list1formula)
exit sub
end if
dim list2items() as string
list2items() = split(list2formula, ";")
if list1items.cells.count <> (ubound(list2items) +1) then
MsgBox ("Count of items in list1 is not the same as count of items in list2:" & vbnewline & vbnewline & "List1 = " & list1items.cells.count & " cells " & vbnewline & "List2 = " & (ubound(list2items) +1) & " items")
Exit sub
end if
dim cell as range
dim listIndex as long
application.calculation = xlCalculationManual
application.screenupdating = false
with resultsRange
for each cell in list1range
list1range.value2 = cell.value2
list2range.value2 = list2items(listindex)
list1range.parent.calculate ' Sheet needs to re-calculate '
' Column 1 = list1'
' Column 2 = list2'
' Columns 3 to 34 = K9:K40'
' Columns 35 to 66 = Z9:Z40'
.offset(listindex, 0) = cell.value2 ' Value from list1'
.offset(listindex, 1) = list2items(listindex) ' Value from list2'
rangeToCopy1.copy
'below needs to appear on a new line'
.offset(listIndex, 2).pastespecial paste:=xlPasteValuesAndNumberFormats,
transpose:=True
rangeToCopy2.copy
'below needs to appear on a new line'
.offset(listIndex, 34).pastespecial paste:=xlPasteValuesAndNumberFormats,
transpose:=True
listindex = listindex +1
next cell
application.calculation = xlautomatic
application.screenupdating = true
end with
End Sub