VBA – select工作簿中的特定工作表进行循环
我有一个可变数量的工作表的Excel工作簿。 此刻，我正在循环查看所有表格，并在其中find特定的列以search超过某个阈值的数字。 列和阈值由需要由用户填写的input框确定。 如果列中的数字，比如列“J”，第10行高于阈值，则第10行被复制并粘贴到新创build的“汇总”表格中。
我现在正在努力与特定的select表。 我并不总是想循环遍历所有工作表，而是想要另一个input框或其他东西，我可以select特定工作表（STRG +“sheetx”“sheety”等等），通过循环？！ 任何人有一个想法如何我可以用我的代码完成？ 我知道我必须改变我的“为每个”的声明来替代选定的工作表，但我不知道如何创buildinput框来select特定的标签…
任何帮助感激！
Option Explicit Sub Test() Dim column As String Dim WS As Worksheet Dim i As Long, j As Long, lastRow As Long Dim sh As Worksheet Dim sheetsList As Variant Dim threshold As Long Set WS = GetSheet("Summary", True) threshold = Application.InputBox("Input threshold", Type:=1) column = Application.InputBox("Currency Column", Type:=2) j = 2 For Each sh In ActiveWorkbook.Sheets If sh.Name <> "Summary" Then lastRow = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row For i = 4 To lastRow If sh.Range(column & i) > threshold Or sh.Range(column & i) < -threshold Then sh.Range("a" & i & ":n" & i).Copy Destination:=WS.Range("A" & j) WS.Range("N" & j) = sh.Name j = j + 1 End If Next i End If Next sh WS.Columns("A:N").AutoFit End Sub Function GetSheet(shtName As String, Optional clearIt As Boolean = False) As Worksheet On Error Resume Next Set GetSheet = Worksheets(shtName) If GetSheet Is Nothing Then Set GetSheet = Sheets.Add(after:=Worksheets(Worksheets.Count)) GetSheet.Name = shtName End If If clearIt Then GetSheet.UsedRange.Clear End Function 在“NO-UserForm” 心情中 ，当将Type参数设置为8并使其接受rangeselect时，可以使用Dictionary对象和Application.InputBox()方法的组合。
Function GetSheets() As Variant Dim rng As Range On Error Resume Next With CreateObject("Scripting.Dictionary") Do Set rng = Nothing Set rng = Application.InputBox(prompt:="Select any range in wanted Sheet", title:="Sheets selection", Type:=8) .item(rng.Parent.Name) = rng.Address Loop While Not rng Is Nothing GetSheets = .keys End With End Function
此函数从用户切换到表格的每个范围中获取Parent表格名称，并在用户单击“ Cancelbutton或closures“input框”时停止
被你的“主要”部分利用如下：
Sub main() Dim ws As Worksheet For Each ws In Sheets(GetSheets) '<--| here you call GetSheets() Function and have user select sheets to loop through MsgBox ws.Name Next End Sub
同意UserForm可以提供一个更有吸引力的方式来定义它，但是InputBox方法并不坏。 下面的代码创build了一个InputBox，它以与打印对话框接受页码相同的方式接受一个表单区域条目，即用逗号（1,3,9）分隔的明确图表编号或用连字符（1-9 ）。
这看起来像很多代码，但它有一些error handling，以防止丑陋的失败。 您的循环For Each sh In ActiveWorkbook.Sheets中将被类似于代码底部的示例的循环replace。
Sub sheetLoopInputBox() Dim mySheetsArr2(999) 'Gather sheet range from inputbox: mySheets = Replace(InputBox("Enter sheet numbers you wish to work on, eg:" & vbNewLine & vbNewLine & _ "1-3" & vbNewLine & _ "1,3,5,7,15", "Sheets", ""), " ", "") If mySheets = "" Then Exit Sub 'user clicked cancel or entered a blank 'Remove spaces from string: If InStr(mySheets, " ") Then mySheets = Replace(mySheets, " ", "") If InStr(mySheets, ",") Then 'Comma separated values... 'Create array: mySheetsArr1 = Split(mySheets, ",") 'Test if user entered numbers by trying to do maths, and create final array: On Error Resume Next For i = 0 To UBound(mySheetsArr1) mySheetsArr2(i) = mySheetsArr1(i) * 1 If Err.Number <> 0 Then Err.Clear MsgBox "Error, did not understand sheets entry." Exit Sub End If Next i i = i - 1 ElseIf InStr(mySheets, "-") Then 'Hyphen separated range values... 'Check there's just one hyphen If Len(mySheets) <> (Len(Replace(mySheets, "-", "")) + 1) Then MsgBox "Error, did not understand sheets entry." Exit Sub End If 'Test if user entered numbers by trying to do maths: On Error Resume Next temp = Split(mySheets, "-")(0) * 1 temp = Split(mySheets, "-")(1) * 1 If Err.Number <> 0 Then Err.Clear MsgBox "Error, did not understand sheets entry." Exit Sub End If On Error GoTo 0 'Create final array: i = 0 i = i - 1 For j = Split(mySheets, "-")(0) * 1 To Split(mySheets, "-")(1) * 1 i = i + 1 mySheetsArr2(i) = j Next j End If 'A loop to do your work: '(work through the sheet numbers stored in the array mySheetsArr2): For j = 0 To i 'example1: MsgBox mySheetsArr2(j) 'example2: 'Sheets(mySheetsArr2(j)).Cells(1, 1).Value = Now() 'Sheets(mySheetsArr2(j)).Columns("A:A").AutoFit Next j End Sub