Help with VBA code

nihad

New Member
Joined
Feb 24, 2021
Messages
40
Office Version
  1. 365
Platform
  1. Windows
Hi all

I have found below code to split one excel file into multiples:

VBA Code:
Option Explicit

Const Target_Folder As String = "C:\Users\nihad.TF\Desktop\split"
Dim wsSource As Worksheet, wsHelper As Worksheet
Dim LastRow As Long, LastColumn As Long

Sub SplitDataset()
    
    Dim collectionUniqueList As Collection
    Dim i As Long
    
    Set collectionUniqueList = New Collection
    
    Set wsSource = ThisWorkbook.Worksheets("TransactionList")
    Set wsHelper = ThisWorkbook.Worksheets("Helper")
    
    ' Clear Helper Worksheet
    wsHelper.Cells.ClearContents
    
    With wsSource
        .AutoFilterMode = False
        
        LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        LastColumn = .Cells(1, Columns.Count).End(xlToLeft).Column
        
        If .Range("A2").Value = "" Then
            GoTo Cleanup
        End If
        
        Call Init_Unique_List_Collection(collectionUniqueList, LastRow)
        
        Application.DisplayAlerts = False
        
        For i = 1 To collectionUniqueList.Count
                SplitWorksheet (collectionUniqueList.Item(i))
        Next i
        
        ActiveSheet.AutoFilterMode = False
        
    End With

Cleanup:

    Application.DisplayAlerts = True
    Set collectionUniqueList = Nothing
    Set wsSource = Nothing
    Set wsHelper = Nothing

End Sub

Private Sub Init_Unique_List_Collection(ByRef col As Collection, ByVal SourceWS_LastRow As Long)
    
    Dim LastRow As Long, RowNumber As Long
    
    ' Unique List Column
    wsSource.Range("D2:D" & SourceWS_LastRow).Copy wsHelper.Range("A1")
    
    With wsHelper
        
        If Len(Trim(.Range("A1").Value)) > 0 Then
            
            LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
            
            .Range("A1:A" & LastRow).RemoveDuplicates 1, xlNo
            
            LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
            
            .Range("A1:A" & LastRow).Sort .Range("A1"), Header:=xlNo
            
            LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
            
            On Error Resume Next
            For RowNumber = 1 To LastRow
                col.Add .Cells(RowNumber, "A").Value, CStr(.Cells(RowNumber, "A").Value)
            Next RowNumber
           
        End If
    
    End With
    
End Sub

Private Sub SplitWorksheet(ByVal Category_Name As Variant)
    
    Dim wbTarget As Workbook
    
    Set wbTarget = Workbooks.Add
    
    With wsSource

        With .Range(.Cells(1, 1), .Cells(LastRow, LastColumn))

            .AutoFilter .Range("D1").Column, Category_Name
            
            .Copy
            
            'wbTarget.Worksheets(1).PasteSpecial xlValues
            wbTarget.Worksheets(1).Paste
            wbTarget.Worksheets(1).Name = Category_Name
            
            wbTarget.SaveAs Target_Folder & Category_Name & ".xlsx", 51
            wbTarget.Close False
            
        End With
        
    End With
    
    Set wbTarget = Nothing
    
End Sub


but I'm getting Runtime Error 1004 AutoFilter method of Rane class failed

my error is in this part of the code:

VBA Code:
Private Sub SplitWorksheet(ByVal Category_Name As Variant)
    
    Dim wbTarget As Workbook
    
    Set wbTarget = Workbooks.Add
    
    With wsSource

        With .Range(.Cells(1, 1), .Cells(LastRow, LastColumn))

            .AutoFilter .Range("D1").Column, Category_Name
            
            .Copy
            
            'wbTarget.Worksheets(1).PasteSpecial xlValues
            wbTarget.Worksheets(1).Paste
            wbTarget.Worksheets(1).Name = Category_Name
            
            wbTarget.SaveAs Target_Folder & Category_Name & ".xlsx", 51
            wbTarget.Close False
            
        End With
        
    End With
    
    Set wbTarget = Nothing
    
End Sub
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK

Forum statistics

Threads
1,223,230
Messages
6,170,883
Members
452,364
Latest member
springate

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top