excel vba循环通过工作表失败

我不知道为什么这个函数不通过工作表循环，我错过了什么？

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

我试过循环工作表编号，但是没有工作，所以我现在试图通过工作表名称循环。 这也是行不通的。

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

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