Вводные поля ввода кода более интерактивны

Question

В настоящее время я работаю над следующим кодом, который выполняет поиск по всем вкладкам в книге Excel, выбирает все валюты, превышающие определенный порог в определенном столбце «J», и если критерии удовлетворяют строке, содержащей валюта, которая является более высоким порогом, вставлена ​​в новую созданную вкладку под названием «summary».

Теперь мой вопрос: 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 

Answer 1

Вы можете установить UserForm в качестве входных данных в программу - что-то вроде того, что следует. Вам нужно только один раз запустить подменю «CreateUserForm», чтобы обработчики событий UserForm1 были настроены в вашей электронной таблице. Как только это будет сделано, вы можете запустить «Тест», чтобы увидеть сам UserForm1. Вы можете редактировать обработчики событий, чтобы проверить ввод пользователя или отклонить его, если потребуется. Также после установки UserForm1 вы можете перемещать различные ярлыки и списки, и, конечно же, создавать новые. Он должен выглядеть следующим образом:

Вы можете выбрать, как много листов, как требуется от последнего ListBox и выборы будут добавлены в VBA коллекции. См. MsgBox в начале вашего кода и играйте с вводом значений/выборов в поле пользователя, чтобы узнать, что он делает.

Обработчик UserForm, который вызывается при нажатии кнопки okay, сохранит выбор для глобальных переменных, чтобы их можно было отобрать в коде.

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 2

Вы можете попробовать это

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 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