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

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.

1. Change data validation list1 to first item in list
2. Change data validation list2 to first item in list
3. Copy range from sheet1 to sheet2, first item in list + first item in list + copied range
4. 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