Eingabefelder einfügen, die Code interaktiver machen

Question

Ich arbeite derzeit an dem folgenden Code, der alle Registerkarten in einer Excel-Arbeitsmappe durchsucht, alle Währungen auswählt, die einen bestimmten Schwellenwert in einer definierten Spalte "J" überschreiten, und wenn die Kriterien erfüllt sind Die Währung, die größer als der Schwellenwert ist, wird in eine neu erstellte Registerkarte mit der Bezeichnung "Zusammenfassung" eingefügt.

Jetzt ist meine Frage: 1. Gibt es eine Chance, diesen Code interaktiver zu machen? Ich möchte ein Eingabefeld hinzufügen, in dem der Benutzer seinen Schwellenwert eingibt (in meinem Beispiel 1000000), und dieser Schwellenwert wird zum Durchlaufen aller Registerkarten verwendet. 2. Es wäre toll, ein Eingabefeld wie "Spalte mit Währung auswählen" zu erhalten, da Spalte "J" nicht immer gesetzt wird, sondern auch eine andere Spalte ("I", "M" usw.) Dies wird dann für alle Blätter gleich sein. 3. Jede Möglichkeit, bestimmte Blätter innerhalb der Arbeitsmappe auszuwählen (STRG + "Blatt" "Blatt" usw.), die dann in meine Schleife eingefügt werden und alle anderen werden vernachlässigt?

Jede Hilfe, besonders für meine Probleme in Frage 1 und 2 wird geschätzt. Frage 3 wäre nur ein „nice-to-have“ Ding

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

Sie versuchen, eine Userform als Eingabe in das Programm einstellen können - so etwas wie, was folgt. Sie müssen den Unterbefehl 'CreateUserForm' nur einmal ausführen, um die in Ihrem Arbeitsblatt eingerichteten UserForm1-Ereignisbehandlungsroutinen zu erhalten. Sobald das erledigt ist, können Sie den 'Test' ausführen, um UserForm1 selbst zu sehen. Sie können die Ereignisbehandlungsroutinen bearbeiten, um die Benutzereingaben zu überprüfen oder sie bei Bedarf abzulehnen. Auch wenn das UserForm1 eingerichtet ist, können Sie die verschiedenen Labels und Listenfelder verschieben und natürlich neue erstellen. Es soll wie folgt aussehen:

Sie können so viele Blätter auswählen, wie aus dem letzten Listenfeld erforderlich, und die Auswahl wird zu einer vba Sammlung hinzugefügt werden. Sehen Sie sich die MsgBox am Anfang Ihres Codes an und spielen Sie mit der Eingabe von Werten/Auswahlen in die Benutzerbox, um zu sehen, was sie tut.

Der UserForm-Handler, der beim Drücken der Schaltfläche OK aufgerufen wird, speichert die Auswahlen in globalen Variablen, damit sie im Code abgerufen werden können.

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

Möglicherweise möchten Sie diese

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

Der folgende Code funktioniert für meine Zwecke mit Ausnahme der Auswahl der einzelnen Registerkarten, um eine Schleife durch:

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