Excel VBA循环通过工作表失败

Question

我不知道为什么该功能不会在工作表中循环，我想念什么？

我已经遍历了几乎所有可以在堆栈溢出和Google上找到的资源，但是找不到可以实现的答案。

我尝试遍历工作表编号，但是没有用，所以现在尝试遍历工作表名称。 这也不起作用。

我敢肯定这是一个小错误，但经过几天的搜索却找不到原因。

Sub CreateUniquesList()

    Dim WS_Count As Integer 'number of WorkSheets
    Dim Sheet As Integer 'WorkSheet number
    Dim Uniques() As String 'Array of all unique references
    Dim UniquesLength As Integer
    Dim size As Integer 'number of items to add to Uniques
    Dim Row As Integer 'row number
    Dim Column As Variant 'column number
    Dim Columns As Variant
    Dim blanks
    Dim LastRow As Integer
    Dim i As Integer

    Dim wks As Variant, wksNames() As String

    WS_Count = ActiveWorkbook.Worksheets.Count
    ReDim wksNames(WS_Count - 1)
    i = 0
    For Each wks In Worksheets
        wksNames(i) = wks.Name
        i = i + 1
    Next

    Columns = Array(3, 4, 8, 11, 12, 17, 18)
    ReDim Uniques(0)
    Uniques(0) = "remove this item"
    WS_Count = ActiveWorkbook.Worksheets.Count
'    For Sheet = 1 To WS_Count
    For Each wks In wksNames
        For Each Column In Columns
'            LastRow = ActiveWorkbook.Worksheets(Sheet).Cells(Rows.Count, Column).End(xlUp).Row
'            size = WorksheetFunction.CountA(Worksheets(Sheet).Columns(Column)) - 1
            LastRow = ActiveWorkbook.Worksheets(wks).Cells(Rows.Count, Column).End(xlUp).Row
            size = WorksheetFunction.CountA(Worksheets(wks).Columns(Column)) - 1
            UniquesLength = UBound(Uniques) - LBound(Uniques) + 1
            ReDim Preserve Uniques(UniquesLength + size - 1)
            blanks = 0
            i = 1
            For Row = LastRow To 2 Step -1
                If Cells(Row, Column).Value <> "" Then
                    Uniques(UniquesLength + i - 1 - blanks) = Cells(Row, Column).Value
                Else
                    blanks = blanks + 1
                End If
                i = i + 1
            Next Row
        Next Column
    Next wks
'    Next Sheet

    'remove first unique element
    For i = 1 To UBound(Uniques)
        Uniques(i - 1) = Uniques(i)
    Next i
    ReDim Preserve Uniques(UBound(Uniques) - 1)
End Sub

Answer 1

我看了一下代码，并重写了其中相当一部分，因为我认为不需要太多（可能是您尝试使事情正常进行的过程中遗留下来的）。 试试看，如果您不了解任何内容，请发表评论，我会进一步解释。

Sub CreateUniquesList()

    Dim Uniques() As String 'Array of all unique references
    Dim Row As Integer 'row number
    Dim Column As Variant 'column number
    Dim Columns As Variant
    Dim LastRow As Integer
    Dim wks As Worksheet

    Columns = Array(3, 4, 8, 11, 12, 17, 18)
    ReDim Uniques(0)

    For Each wks In ThisWorkbook.Worksheets
        For Each Column In Columns
            LastRow = wks.Cells(wks.Rows.Count, Column).End(xlUp).Row
            For Row = LastRow To 2 Step -1
                If wks.Cells(Row, Column).Value <> "" Then
                    Uniques(UBound(Uniques)) = wks.Cells(Row, Column).Value ' set the last element of the array to the value
                    ReDim Preserve Uniques(UBound(Uniques)+1)   ' increment the size of the array
                End If
            Next Row
        Next Column
    Next wks

    ' lose the last element of the array as it's one larger than it needs to be
    ReDim Preserve Uniques(UBound(Uniques) - 1)

End Sub

Answer 2

尝试这个

 WS_Count = ActiveWorkbook.Worksheets.Count 
 '    For Sheet = 1 To WS_Count
 For Each wks In Worksheets
 For Each Column In Columns
 'LastRow = ActiveWorkbook.Worksheets(Sheet).Cells(Rows.Count,column).End(xlUp).Row
 'size = WorksheetFunction.CountA(Worksheets(Sheet).Columns(Column)) - 1
 LastRow = ActiveWorkbook.Worksheets(wks.Name).Cells(Rows.Count,Column).End(xlUp).Row
 size = WorksheetFunction.CountA(Worksheets(wks.Name).Columns(Column)) - 1
 UniquesLength = UBound(Uniques) - LBound(Uniques) + 1
 ReDim Preserve Uniques(UniquesLength + size - 1)
 blanks = 0
 i = 1
 For Row = LastRow To 2 Step -1
 If Cells(Row, Column).Value <> "" Then
 Uniques(UniquesLength + i - 1 - blanks) = Cells(Row, Column).Value
 Else
 blanks = blanks + 1
 End If
 i = i + 1
 Next Row
 Next Column
 Next wks