Question

我目前正在处理以下代码，该代码搜索excel工作簿中的所有选项卡，在定义的列中选择大于特定阈值的所有货币＆＃34; J＆＃34;如果符合条件，则包含更高阈值的货币的行将粘贴到名为＆＃34; summary＆＃34;的新创建选项卡中。

现在我的问题是： 1.有没有机会使这些代码更具互动性？我想做的是添加一个输入框，用户在其中键入他的阈值（在我的示例中为1000000），此阈值用于循环遍历所有选项卡。 2.得到一个像＃＆＃34;选择包含货币＆＃34;的列的输入框，作为列＆＃34; J＆＃34;不会一直设置，它也可能是另一列（＆＃34;我＆＃34;，＆＃34; M＆＃34;等等）但是对于所有工作表来说都是相同的。 3.有机会在工作簿中选择某些工作表（STRG +＆＃34; sheetx＆＃34;＆＃34; sheety＆＃34; etc ....）然后粘贴到我的循环中而其他所有工作簿都被忽略了？

任何帮助，特别是对于问题1和2中的问题，我们表示赞赏。问题3只是一个很好的选择＆＃34;事情

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

Answer 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

Answer 2

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

您可以根据需要从上一个列表框中选择任意数量的工作表，这些选择将添加到vba集合中。请参阅代码开头的MsgBox，然后在用户框中输入值/选项以查看其功能。

按下okay按钮时调用的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

Answer 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

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

3 个答案: