使用列表框对特定的表进行循环——VBA

I am trying to loop through multiple worksheets and find values above a certain threshold. If those values are found, the whole line containing the value above threshold should be copied into a new created "Summary"-Sheet.

我正在尝试遍历多个工作表并找到某个阈值以上的值。如果找到这些值，应该将包含阈值以上值的整行复制到一个新的创建的“摘要”-Sheet中。

My UserForm so far looks like this:

到目前为止，我的用户表单是这样的:

And my code like this:

我的代码是这样的:

Option Explicit


Private Sub UserForm_Initialize()
Dim N As Long
For N = 1 To ActiveWorkbook.Sheets.Count
    Sheets_txt.AddItem ActiveWorkbook.Sheets(N).Name
Next N
End Sub

Private Sub CommandButton1_Click()

Dim SelectedItems As String

Dim column As String
Dim WS As Worksheet
Dim i As Long, j As Long, lastRow As Long, k As Long
Dim sh As Worksheet
Dim sheetsList As Variant
Dim threshold As Long

Set WS = ThisWorkbook.Worksheets.Add
WS.Name = "Summary"

threshold = Me.Threshold_txt.Value
column = Me.Column_txt.Value

j = 2

For k = 0 To Sheets_txt.ListCount - 1
    If Sheets_txt.Selected(i) = True Then
    SelectedItems = SelectedItems & Sheets_txt.List(i)
    lastRow = SelectedItems.Cells(SelectedItems.Rows.Count, "A").End(xlUp).Row
        For i = 4 To lastRow
            If SelectedItems.Range(column & i) > threshold Or SelectedItems.Range(column & i) < -threshold Then
                SelectedItems.Range("a" & i & ":n" & i).Copy Destination:=WS.Range("A" & j)
                WS.Range("N" & j) = SelectedItems.Name
                j = j + 1
            End If
        Next i
    End If
Next k
WS.Columns("A:N").AutoFit
End Sub


Private Sub CommandButton2_Click()
Unload Me
End Sub

However I am struggeling with the For loop. The code should be looping through all selected sheets and do the things I wrote above. However using a variable SelectedItems to store all strings that meet the condition of If Sheets_txt.Selected(i) = True is not working. In my case it debugs at lastRow = SelectedItems.Cells(SelectedItems.Rows.Count, "A").End(xlUp).Row and points to (SelectedItems.Rows.Count.

然而，我正在与For循环做斗争。代码应该循环遍历所有选定的表，并执行我上面编写的操作。然而，使用变量selecteditem来存储满足If Sheets_txt.Selected(i) = True的所有字符串是无效的。在我的例子中，它在lastRow = SelectedItems.Cells(SelectedItems.Rows)上调试。数,“一个”)指标(xlUp)。最终行和指向(selecteditemps .Row . count)。

How can I get this loop working? Any help appreciated!

如何让循环工作?任何帮助表示赞赏!

1 个解决方案

#1

You could try this (untested) code.

您可以尝试这个(未经测试的)代码。

UPDATE: The editor of this question made some slight changes to the inital code suggested and tested this code now.

更新:这个问题的编辑器对建议的inital代码做了一些细微的修改，现在对该代码进行了测试。

Option Explicit

Private Sub UserForm_Initialize()
Dim N As Long
For N = 1 To ActiveWorkbook.Sheets.Count
    Sheets_txt.AddItem ActiveWorkbook.Sheets(N).Name
Next N
End Sub

Private Sub CommandButton1_Click()

    Dim SelectedItems As String
    Dim column As String
    Dim WS As Worksheet
    Dim i As Long, j As Long, lastRow As Long, k As Long
    Dim sh As Worksheet
    Dim sheetsList As Variant
    Dim threshold As Long

    Set WS = ThisWorkbook.Worksheets.Add
    WS.Name = "Summary"

    threshold = Me.Threshold_txt.Value
    column = Me.Column_txt.Value

    j = 1
    For k = 0 To Sheets_txt.ListCount - 1
        If Sheets_txt.Selected(k) = True Then
            With Worksheets(Sheets_txt.List(k))
                lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
                For i = 4 To lastRow
                    If .Cells(i, column) > threshold Or  .Cells(i, column) < -threshold Then
                         j = j + 1
                         Intersect(.Range("A:N"), .Cells(i, column).EntireRow).Copy Destination:=WS.Cells(j,2)
                         WS.Cells(j, "A")= .Name
                     End If
                Next
            End With
            If WS.Cells(j, "A")= .Name then j = j + 1 '<--| add a blank line if current sheet has produced at least one pasted line
        End If
    Next
    WS.Columns("A:N").AutoFit
End Sub


Private Sub CommandButton2_Click()
    Me.Hide 'and move the 'Unload' command in the sub calling the userform
End Sub

#1