excel vba loop through worksheets fails - vba

Question

I don't know why this function doesn't loop through the worksheets , what am I missing ?
I've gone through Almost every resource I can find both on stack overflow and Google but could not find an answer that I could implement.
I've tried looping through worksheet numbers however that didn't work so I am now attempting to loop through worksheet names. This also does not work.
I'm pretty sure it's a small error but I could not find the cause after days of searching.
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

I took a look at the code and have rewritten a fair portion of it as I don't think a lot of it was necessary (probably leftover from your attempts to make things work). Try this, and if you don't understand any of it, post a comment and I'll explain further.
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

Try this
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