插入输入框使代码更具交互性答案

【问题标题】：Insert inputboxes making code more interactive插入输入框使代码更具交互性
【发布时间】：2017-02-18 23:12:11
【问题描述】：

我目前正在处理以下代码，该代码正在搜索 excel 工作簿中的所有选项卡，在定义的列“J”中选择大于某个阈值的所有货币，如果满足条件，则包含大于阈值的货币的行粘贴在名为“摘要”的新创建选项卡中。

现在我的问题是： 1.有没有机会让这段代码更具交互性？我想做的是添加一个输入框，用户在其中输入他的阈值（在我的示例中为 1000000），并且该阈值用于循环遍历所有选项卡。 2. 最好有一个像“选择包含货币的列”这样的输入框，因为“J”列不会一直设置，它也可以是另一列（“I”，“M”等）但是这个那么所有工作表都将相同。 3.有没有机会在工作簿中选择某些工作表（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

【问题讨论】：

就目前而言，这太宽泛了。您有 3 个问题应该分别提出。尝试修改您的代码以回答第一个问题，如果成功，请继续下一个问题。如果您尝试的修改不起作用，请发布该特定问题，包括错误消息或不良行为。
你可能是对的，我试试这个方法。
您有两个可能的部分答案。即使他们是对的，搜索“将工作表循环限制到特定工作表”或“选择要循环通过的工作表”的用户也不太可能看到它们。带有明确标题的简短问题将适用于您和 SO 社区。span>

标签： vba excel inputbox

【解决方案1】：

你可以试试这个

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

【讨论】：

感谢您的帮助！这很好用，但是否也可以插入一个输入框，我可以在其中定义包含我的货币值的列？
不客气。是的，这是可能的，您可以按照与阈值相同的方式做很多事情。我不在我的电脑旁，但您自己尝试并寻求帮助，以防卡住。最后，您可能希望将我的答案标记为已接受。谢谢。
我想通了。感谢您在这方面的帮助，谢谢！
如果你还有一些时间，也许你可以在我完成之前对这段代码的最后一个问题有一些想法：;)stackoverflow.com/questions/42325891/…

【解决方案2】：

您可以将用户窗体设置为程序的输入 - 如下所示。您只需运行一次“CreateUserForm”子程序即可在电子表格中设置 UserForm1 事件处理程序。完成后，您可以运行“测试”来查看 UserForm1 本身。您可以编辑事件处理程序以检查用户输入或在需要时拒绝它。此外，一旦设置了 UserForm1，您就可以移动各种标签和列表框，当然，还可以创建新的。它应该是这样的：

您可以根据需要从最后一个列表框中选择任意数量的工作表，这些选择将被添加到 vba 集合中。查看代码开头的 MsgBox 并在用户框中输入值/选择以查看它的作用。

当您按下 OK 按钮时调用的 UserForm 处理程序会将选择保存到全局变量中，以便可以在代码中获取它们。

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

【讨论】：

感谢您的帮助！不幸的是，我以前从未使用过 UserForms，也不知道如何让它在我的工作簿中运行
没关系。无论如何，我已经为其他人添加了一张图片，如果您将来想重新访问它
这正是我想要的！您知道如何将其实现到我的项目中（在 Dropbox 中附加的 xlsx 测试文件）吗？ dropbox.com/s/ofngqkxz3accrso/Test.xlsx?dl=0
是的，你所说的'threshold'和'currencyCol'变量 - 但不是collitems。您想使用 selectedSheets 这是一个 VBA 集合，其中包含您在用户窗体的“选择工作表”列表框中选择的每个工作表名称。您可以使用“selectedSheets”上的索引来访问每个工作表名称。要获得第一个，您使用“selectedSheets(1)”，第二个“selectedSheets(2)”等）。无论如何，您都可以在 Google 上搜索 Collection VBA 数据类型 - 有大量示例可供参考。
很高兴你让它工作了——一旦你的用户表单工作了，就很难回到输入框。是的，您应该能够做到这一点 - 预加载现有的默认值，以便您选择需要更改的任何内容。您必须更改 UserForm1 的 UserForm_Initialize 子中的代码。

【解决方案3】：

以下代码适用于我的目的，除了选择要循环的单个选项卡：

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

【讨论】：