CODEWITHSUNDEEP
vbaexcel
Eitan Waks
Eitan Waks

Reputation: 49

excel vba loop through worksheets fails

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

Upvotes: 0

Views: 335

Answers (2)

Dave
Dave

Reputation: 4356

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

Upvotes: 1

Maddy
Maddy

Reputation: 781

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

Upvotes: 0

Related Questions