Nov 15 2022 03:30 AM
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
Nov 15 2022 04:58 AM
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