Forum Discussion

ali1712's avatar
ali1712
Copper Contributor
Nov 15, 2022

Saving a newly made sheet as an xlsx file in the same pathway as the file from which the sheet came.

I'm trying to create a macro that can separate a specific type of bank statement so that there is a separate file for each type of account number. For example, one of the statements will have lines for four different accounts, and after running the macro there will be a separate xlsx file for each account, saved in the same file as the original bank statement. The code I've got is able to separate each sheet, but I can't figure out how to then save each sheet within the same pathway. My code is shown below. I'm new to excel so apologies if any of my terminology is incorrect!

 

Sub Split_data_macro()
Dim L As Long
Dim DS As Worksheet
Dim X, Y As Integer
Dim XCL As Long
Dim MARY As Variant
Dim title As String
Dim titlerow As Integer
Application.ScreenUpdating = False
Set DS = ActiveSheet
L = DS.Cells(DS.Rows.Count, 2).End(xlUp).Row
title = "B1"
titlerow = DS.Range(title).Cells(1).Row
XCL = DS.Columns.Count
DS.Cells(22, XCL) = "Unique"
For Y = 2 To L
DS.Cells(Y, 2) = Right(DS.Cells(Y, 2), 4)
Next
For X = 2 To L
On Error Resume Next
If DS.Cells(X, 2) <> "" And Application.WorksheetFunction.Match(DS.Cells(X, 2), DS.Columns(XCL), 0) = 0 Then
DS.Cells(DS.Rows.Count, XCL).End(xlUp).Offset(1) = DS.Cells(X, 2)
End If
Next
MARY = Application.WorksheetFunction.Transpose(DS.Columns(XCL).SpecialCells(xlCellTypeConstants))
DS.Columns(XCL).Clear
For X = 2 To UBound(MARY)
DS.Range(title).AutoFilter field:=2, Criteria1:=MARY(X) & ""
If Not Evaluate("=ISREF('" & MARY(X) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = MARY(X) & ""
Else
Sheets(MARY(X) & "").Move after:=Worksheets(Worksheets.Count)
End If
DS.Range("A" & titlerow & ":A" & L).EntireRow.Copy Sheets(MARY(X) & "").Range("A1")
Next
DS.AutoFilterMode = False
DS.Activate
Application.ScreenUpdating = True

End Sub

excel
Macros and VBA

1 Reply

  • HansVogelaar's avatar
    HansVogelaar
    MVP
    Nov 15, 2022

    ali1712 

    Try this version:

    Sub Split_data_macro()
    Dim L As Long
    Dim DS As Worksheet
    Dim X As Integer, Y As Integer
    Dim XCL As Long
    Dim MARY As Variant
    Dim title As String
    Dim titlerow As Integer
    Dim WB As Workbook
    Dim WS As Worksheet
    Dim Acct As String
    Dim sPath As String
    Application.ScreenUpdating = False
    sPath = ActiveWorkbook.Path
    If Right(sPath, 1) <> Application.PathSeparator Then
        sPath = sPath & Application.PathSeparator
    End If
    Set DS = ActiveSheet
    L = DS.Cells(DS.Rows.Count, 2).End(xlUp).Row
    title = "B1"
    titlerow = DS.Range(title).Cells(1).Row
    XCL = DS.Columns.Count
    DS.Cells(22, XCL) = "Unique"
    For Y = 2 To L
        DS.Cells(Y, 2) = Right(DS.Cells(Y, 2), 4)
    Next Y
    On Error Resume Next
    For X = 2 To L
        If DS.Cells(X, 2) <> "" And Application.WorksheetFunction.Match(DS.Cells(X, 2), DS.Columns(XCL), 0) = 0 Then
            DS.Cells(DS.Rows.Count, XCL).End(xlUp).Offset(1) = DS.Cells(X, 2)
        End If
    Next X
    MARY = Application.WorksheetFunction.Transpose(DS.Columns(XCL).SpecialCells(xlCellTypeConstants))
    DS.Columns(XCL).Clear
    For X = 2 To UBound(MARY)
        Acct = CStr(MARY(X))
        DS.Range(title).AutoFilter Field:=2, Criteria1:=Acct
        Set WB = Workbooks.Add(xlWBATWorksheet)
        Set WS = WB.Worksheets(1)
        WS.Name = Acct
        DS.Range("A" & titlerow & ":A" & L).EntireRow.Copy WS.Range("A1")
        WB.Close SaveChanges:=True, Filename:=sPath & Acct
    Next X
    DS.AutoFilterMode = False
    DS.Activate
    Application.ScreenUpdating = True
End Sub

Resources