插入input框使代码更具交互性
我目前正在研究下面的代码，它是通过Excel工作簿中的所有选项卡进行search，select定义的列“J”中的某个阈值以上的所有货币，如果符合条件，则包含更大阈值货币的行被粘贴一个名为“摘要”的新build标签。
现在我的问题是：1.有没有机会使这个代码更具互动性？ 我想要做的是添加一个input框，用户input他的阈值（在我的例子1000000），这个阈值是用来循环所有标签。 2.得到一个像“select column contains currency”这样的input框会很棒，因为列J将不会被全部设置，也可能是另一个列（“I”，“M”等）那么所有的床单都是一样的。 3.是否有机会select工作簿中的某些工作表（STRG +“sheetx”“sheety”等），然后将其粘贴到我的循环中而忽略所有其他工作表？
任何帮助，特别是对于问题1和问题2中的问题，我感激不尽。 问题3只会是一件“好事”的事情
Option Explicit Sub Test() Dim WS As Worksheet Set WS = Sheets.Add WS.Name = "Summary" Dim i As Long, j As Long, lastRow As Long Dim sh As Worksheet With Sheets("Summary") .Cells.Clear End With 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("J" & i) > 1000000 Or sh.Range("J" & i) < -1000000 Then sh.Range("a" & i & ":n" & i).Copy Destination:=Worksheets("Summary").Range("A" & j) Sheets("Summary").Range("N" & j) = sh.Name j = j + 1 End If Next i End If Next sh Sheets("Summary").Columns("A:N").AutoFit End Sub 您可以将用户窗体设置为程序的input，如下所示。 您只需运行一次“CreateUserForm”子文件，即可在电子表格中设置UserForm1事件处理程序。 一旦完成，您可以运行“testing”来查看UserForm1本身。 您可以编辑事件处理程序来检查用户input，或者在需要时拒绝它。 同样，一旦UserForm1被设置，你可以移动各种标签和列表框，当然，创build新的。 它应该是这样的：
您可以根据需要从最后一个列表框中select多个图纸，并将select添加到vba集合中。 在你的代码开始处看到MsgBox，并在input值/select到用户框中看看它是什么。
当您按下okaybutton时调用的UserForm处理程序将保存到全局variables的select，以便他们可以在代码中拾取。
Option Explicit ' Global Variables used by UserForm1 Public lst1BoxData As Variant Public threshold As Integer Public currencyCol As String Public selectedSheets As Collection ' Only need to run this once. It will create UserForm1. ' If run again it will needlessly create another user form that you don't need. ' Once it's run you can modify the event handlers by selecting the UserForm1 ' object in the VBAProject Menu by right clicking on it and selecting 'View Code' ' Note that you can select multiple Sheets on the last listbox of the UserForm ' simply by holding down the shift key. Sub CreateUserForm() Dim myForm As Object Dim X As Integer Dim Line As Integer 'This is to stop screen flashing while creating form Application.VBE.MainWindow.Visible = False Set myForm = ThisWorkbook.VBProject.VBComponents.Add(3) 'Create the User Form With myForm .Properties("Caption") = "Currency Settings" .Properties("Width") = 322 .Properties("Height") = 110 End With ' Create Label for threshold text box Dim thresholdLabel As Object Set thresholdLabel = myForm.Designer.Controls.Add("Forms.Label.1") With thresholdLabel .Name = "lbl1" .Caption = "Input Threshold:" .Top = 6 .Left = 6 .Width = 72 End With 'Create TextBox for the threshold value Dim thresholdTextBox As Object Set thresholdTextBox = myForm.Designer.Controls.Add("Forms.textbox.1") With thresholdTextBox .Name = "txt1" .Top = 18 .Left = 6 .Width = 75 .Height = 16 .Font.Size = 8 .Font.Name = "Tahoma" .borderStyle = fmBorderStyleSingle .SpecialEffect = fmSpecialEffectSunken End With ' Create Label for threshold text box Dim currencyLabel As Object Set currencyLabel = myForm.Designer.Controls.Add("Forms.Label.1") With currencyLabel .Name = "lbl2" .Caption = "Currency Column:" .Top = 6 .Left = 100 .Width = 72 End With 'Create currency column ListBox Dim currencyListBox As Object Set currencyListBox = myForm.Designer.Controls.Add("Forms.listbox.1") With currencyListBox .Name = "lst1" .Top = 18 .Left = 102 .Width = 52 .Height = 55 .Font.Size = 8 .Font.Name = "Tahoma" .borderStyle = fmBorderStyleSingle .SpecialEffect = fmSpecialEffectSunken End With ' Create Label for sheet text box Dim sheetLabel As Object Set sheetLabel = myForm.Designer.Controls.Add("Forms.Label.1") With sheetLabel .Name = "lbl3" .Caption = "Select Sheets:" .Top = 6 .Left = 175 .Width = 72 End With 'Create currency column ListBox Dim sheetListBox As Object Set sheetListBox = myForm.Designer.Controls.Add("Forms.listbox.1") With sheetListBox .Name = "lst3" .Top = 18 .Left = 175 .Width = 52 .Height = 55 .Font.Size = 8 .MultiSelect = 1 .Font.Name = "Tahoma" .borderStyle = fmBorderStyleSingle .SpecialEffect = fmSpecialEffectSunken End With 'Create Select Button Dim selectButton As Object Set selectButton = myForm.Designer.Controls.Add("Forms.commandbutton.1") With selectButton .Name = "cmd1" .Caption = "Okay" .Accelerator = "M" .Top = 30 .Left = 252 .Width = 53 .Height = 20 .Font.Size = 8 .Font.Name = "Tahoma" .BackStyle = fmBackStyleOpaque End With ' This will create the initialization sub and the click event ' handler to write the UserForm selections into the global ' variables so they can be used by the code. myForm.CodeModule.InsertLines 1, "Private Sub UserForm_Initialize()" myForm.CodeModule.InsertLines 2, " me.lst1.addItem ""Column I"" " myForm.CodeModule.InsertLines 3, " me.lst1.addItem ""Column J"" " myForm.CodeModule.InsertLines 4, " me.lst1.addItem ""Column M"" " myForm.CodeModule.InsertLines 5, " me.lst3.addItem ""Sheet X"" " myForm.CodeModule.InsertLines 6, " me.lst3.addItem ""Sheet Y"" " myForm.CodeModule.InsertLines 7, " lst1BoxData = Array(""I"", ""J"", ""M"")" myForm.CodeModule.InsertLines 8, "End Sub" 'add code for Command Button myForm.CodeModule.InsertLines 9, "Private Sub cmd1_Click()" myForm.CodeModule.InsertLines 10, " threshold = CInt(Me.txt1.Value)" myForm.CodeModule.InsertLines 11, " currencyCol = lst1BoxData(Me.lst1.ListIndex)" myForm.CodeModule.InsertLines 12, " Set selectedSheets = New Collection" myForm.CodeModule.InsertLines 13, " For i = 0 To Me.lst3.ListCount - 1" myForm.CodeModule.InsertLines 14, " If Me.lst3.Selected(i) = True Then" myForm.CodeModule.InsertLines 15, " selectedSheets.Add Me.lst3.List(i)" myForm.CodeModule.InsertLines 16, " End If" myForm.CodeModule.InsertLines 17, " Next" myForm.CodeModule.InsertLines 18, " Unload Me" myForm.CodeModule.InsertLines 19, "End Sub" 'Add form to make it available VBA.UserForms.Add (myForm.Name) End Sub ' This is your code verbatim except for now ' the UserForm is shown for selecting the ' 1) currency threshold, 2) the column letter ' and 3) the sheets you want to process. ' The MsgBox just shows you what you've ' selected just to demonstrate that it works. Sub Test() Dim WS As Worksheet Set WS = Sheets.Add WS.Name = "Summary" Dim i As Long, j As Long, lastRow As Long Dim sh As Worksheet With Sheets("Summary") .Cells.Clear End With '**** Start: Running & Checking UserForm Output **** UserForm1.Show Dim colItem As Variant Dim colItems As String For Each colItem In selectedSheets: colItems = colItems & " " & colItem Next MsgBox ("threshold=" & threshold & vbCrLf & _ "currencyCol=" & currencyCol & vbCrLf & _ "selectedSheets=" & colItems) '**** End: Running & Checking UserForm Output **** 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("J" & i) > 1000000 Or sh.Range("J" & i) < -1000000 Then sh.Range("a" & i & ":n" & i).Copy Destination:=Worksheets("Summary").Range("A" & j) Sheets("Summary").Range("N" & j) = sh.Name j = j + 1 End If Next i End If Next sh Sheets("Summary").Columns("A:N").AutoFit End Sub
你可能想试试这个
Option Explicit Sub Test() 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) sheetsList = Array("STRG","sheetx","sheety") '<--| fill this array with the sheets names to be looped through threshold = Application.InputBox("Input threshold", Type:=1) j = 2 For Each sh In ActiveWorkbook.Sheets(sheetsList) lastRow = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row For i = 4 To lastRow If sh.Range("J" & i) > threshold Or sh.Range("J" & 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 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
下面的代码适用于我的目的，除了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