VBA - select 工作簿中要循环的特定工作表
VBA - select specific sheets within workbook to loop through
我有一个 excel 工作簿，其中 sheet 的数量可变。目前，我正在遍历所有 sheet 并在其中的特定列中搜索高于特定阈值的数字。列和阈值由需要用户填写的输入框确定。如果列中的数字，假设列 "J" 和第 10 行高于阈值，则复制第 10 行并粘贴到新创建的 "summary" sheet 等
我目前正在为 sheet 的特定 select 离子而苦苦挣扎。我并不总是想遍历所有 sheets，而是希望有另一个输入框或其他我可以 select 特定 sheets 的东西（STRG + "sheetx" "sheety" etc...) 循环通过？！任何人都知道我如何用我的代码完成它？我知道我必须更改我的 "for each" 语句以替换 selected sheets 但我不知道如何创建 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
同意 UserForm 可以提供一种更具吸引力的定义方式，但 InputBox 方法也不错。以下代码创建了一个 InputBox，它接受 sheet 范围条目，其方式与打印对话框接受页码的方式相同，即用逗号 (1, 3, 9) 分隔的显式 sheet 数字或范围用连字符 (1-9) 分隔。
这看起来像很多代码，但它有一些错误处理来防止丑陋的失败。您的循环 For Each sh In ActiveWorkbook.Sheets 将被替换为类似于代码底部示例的循环。
Sub sheetLoopInputBox()
Dim mySheetsArr2(999)
'Gather sheet range from inputbox:
mySheets = Replace(InputBox("Enter sheet numbers you wish to work on, e.g.:" & 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
在 "NO-UserForm" mood 中，您可以在设置其 [=14= 时结合使用 Dictionary 对象和 Application.InputBox() 方法] 参数到 8 并让它接受 range 选择：
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 sheet 名称 sheets 并在用户单击 Cancel 按钮或时停止关闭输入框
将被您的 "main" 子利用如下：
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
我有一个 excel 工作簿，其中 sheet 的数量可变。目前，我正在遍历所有 sheet 并在其中的特定列中搜索高于特定阈值的数字。列和阈值由需要用户填写的输入框确定。如果列中的数字，假设列 "J" 和第 10 行高于阈值，则复制第 10 行并粘贴到新创建的 "summary" sheet 等
我目前正在为 sheet 的特定 select 离子而苦苦挣扎。我并不总是想遍历所有 sheets，而是希望有另一个输入框或其他我可以 select 特定 sheets 的东西（STRG + "sheetx" "sheety" etc...) 循环通过？！任何人都知道我如何用我的代码完成它？我知道我必须更改我的 "for each" 语句以替换 selected sheets 但我不知道如何创建 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
同意 UserForm 可以提供一种更具吸引力的定义方式，但 InputBox 方法也不错。以下代码创建了一个 InputBox，它接受 sheet 范围条目，其方式与打印对话框接受页码的方式相同，即用逗号 (1, 3, 9) 分隔的显式 sheet 数字或范围用连字符 (1-9) 分隔。
这看起来像很多代码，但它有一些错误处理来防止丑陋的失败。您的循环 For Each sh In ActiveWorkbook.Sheets 将被替换为类似于代码底部示例的循环。
Sub sheetLoopInputBox()
Dim mySheetsArr2(999)
'Gather sheet range from inputbox:
mySheets = Replace(InputBox("Enter sheet numbers you wish to work on, e.g.:" & 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
在 "NO-UserForm" mood 中，您可以在设置其 [=14= 时结合使用 Dictionary 对象和 Application.InputBox() 方法] 参数到 8 并让它接受 range 选择：
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 sheet 名称 sheets 并在用户单击 Cancel 按钮或时停止关闭输入框
将被您的 "main" 子利用如下：
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