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

我打算遍历两个数据验证列表，并为每次迭代将sheet1中的范围复制到sheet2中。此代码遍历一个数据验证下拉菜单，并且不会复制我想要的工作表Sheet1中的范围。

将数据验证list1更改为列表中的第一项
将数据验证list2更改为列表中的第一项
从工作表1到工作表2的复制范围，列表中的第一项+列表中的第一项+复制的范围
重复

更新2018-07-27：

这是我的数据验证列表='A的公式。 Dashboard2'！$ B $ 1：$ V $ 1，='A。仪表板'！$ B $ 1：$ V $ 1。还有= 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

未经测试，写在手机上。看看它是否有效，以及它是否满足您的要求。

代码希望验证列表1始终以=符号开头，并且将是对范围的引用-验证列表2是以;分隔的列表。

代码希望称为Dashboard和Result的工作表已经存在。

对于验证列表中的每个项目，代码将尝试将各种范围（从“仪表板”工作表）复制到结果表上的新行。

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

Excel VBA遍历数据验证列表并将范围从工作表复制到新工作表

1 个答案: