Question

我不知道为什么这个函数不会遍历工作表，我缺少什么？

我已经浏览了几乎我在堆栈溢出和谷歌上找到的所有资源，但找不到我可以实现的答案。

我已经尝试循环遍历工作表编号，但是这不起作用，所以我现在试图遍历工作表名称。这也行不通。

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

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

excel vba循环通过工作表失败

2 个答案: