Ah, so the 'Division' column is not column G across all sheets. Is there a workaround this to identify the column by the column title instead of number?
AutoFilter Multiple Sheets, Copy, New Book, Paste to Multiple Sheets
-
noelleburr -
September 29, 2020 at 5:10 AM -
Thread is marked as Resolved.
-
-
-
Not really, as I said earlier, you need to have the same format for each data sheet. If you don't the code becomes more difficult and less efficient
-
Right, I've edited the file so that all my sheets start at A1 and the column to be filtered is at column G for all sheets. But I'm still getting the 'subscript out of range' error and it points to this code when I debug.
-
-
- I've removed the error handling in the second sub and the error is occurring in the collection sub to create the unique list - On your comment here, could you share the amended code?
I am still getting the error for the SaveAs code and have checked through, can't seem to figure out what is causing the issue.
-
-
-
The new workbooks created also don't seem to be filtered properly, it could be an issue with the unique list code..
-
I need to check that but I haven't had time. I assumed it was working. Which version of Excel are you using?
-
Code
Display MoreOption Explicit Dim wsActiveListing As Worksheet Dim LastRow As Long Dim collection_UniqueList As Collection 'unique list is for automation to be applied to any column Sub MainProgram() Dim wb As Workbook Dim oWs As Worksheet Dim instance As Long, iX As Integer Const Output_Folder_Path As String = "C:\Users\NoelleB\Desktop\Report112\" For iX = 1 To ThisWorkbook.Worksheets.Count If iX = 1 Then ''/// add new workbook only once Set wb = Workbooks.Add Application.SheetsInNewWorkbook = ThisWorkbook.Worksheets.Count End If For Each oWs In ThisWorkbook.Worksheets Set wsActiveListing = oWs With wsActiveListing LastRow = .Cells(Rows.Count, "A").End(xlUp).Row 'using column A to figure out the last row number If 2 > LastRow Then Exit Sub Set collection_UniqueList = New Collection Call UniqueList(collection_UniqueList) For instance = 1 To collection_UniqueList.Count .AutoFilterMode = False .Range("A1:Z" & LastRow).AutoFilter .Range("G1").Column, collection_UniqueList.Item(instance) .Range("A1").CurrentRegion.Copy wb.Worksheets(iX).Range("A1") .AutoFilterMode = False Next instance End With Next oWs Next iX wb.SaveAs Filename:=Output_Folder_Path & "\" & "_" & collection_UniqueList.Item(instance) & ".xlsx", FileFormat:=51 wb.Close False Set wb = Nothing MsgBox "Macro complete.", vbInformation Set collection_UniqueList = Nothing Set wsActiveListing = Nothing End Sub Private Sub UniqueList(ByRef col As Collection) Dim RowNumber As Long With wsActiveListing On Error Resume Next For RowNumber = 2 To LastRow collection_UniqueList.Add .Cells(RowNumber, "G").Value, CStr(.Cells(RowNumber, "G").Value) Next RowNumber End With End Sub
What it currently looks like
-
Participate now!
Don’t have an account yet? Register yourself now and be a part of our community!