Hi all,
I have an existing macro that filters based on a user selected column from a worksheet. For example, if the column data has "20 departments", the macro will do an auto filter and generate 20 worksheets for each department.
So I will have Dept A.xls, Dept B.xls, Dept C.xls and so on (depending on how many departments listed in that particular column within the master data worksheet).
My issue is that the generated worksheets s/no number is no longer in sequence.
How do I add in the necessary vba code to correct the S/N number so that it runs 1, 2, 3, 4...in column A3 onwards for all generated worksheets?
Appreciate your help! thanks
Below is the VB code that generates the worksheets:
-------------------------------------------------------------
Sub S_Frm()
'Disbale screen updating for speedup macros working
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
'Application.Calculation = xlCalculationManual
On Error Resume Next
Dim GetPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show <> 0 Then
GetPath = .SelectedItems(1)
'Variables for worksheet , lastrow & lastcolumn of database
Dim WS As Worksheet, LR As Long, LC As Long, IB As String, SColmn As String, LastSheet As Long, Year As String, columnName As String, AnswerYes As String, AnswerNo As String, Setpassword As String, columnNumber As Integer
Set WS = ThisWorkbook.Sheets("Master")
LR = WS.Range("A" & Rows.Count).End(xlUp).Row
LC = WS.Cells(3, Columns.Count).End(xlToLeft).Column
WS.Activate
IB = Application.InputBox("Please select the column you want to split data based on")
SColumn = "" & IB & ":" & IB & ""
WS.Range(SColumn).Copy: WS.Columns("Z:Z").PasteSpecial xlPasteValues
LastSheet = WS.Range("Z" & Rows.Count).End(xlUp).Row
WS.Range("AA3").Formula = "=SUBSTITUTE(RC[-1],""/"",""-"")"
WS.Range("AA3").AutoFill Destination:=Range("AA3:AA" & LastSheet)
WS.Columns("Z:AA").RemoveDuplicates Columns:=1, Header:=xlYes
WS.Columns("AA:AA").Copy: WS.Columns("AA:AA").PasteSpecial xlPasteValues
LastSheet = WS.Range("Z" & Rows.Count).End(xlUp).Row
Year = InputBox("Please enter the words you want to add to the filename.")
columnName = SColumn
columnNumber = Range(columnName).Column
For A = 4 To LastSheet
WS.Cells(3, SColumn).AutoFilter Field:=columnNumber, Criteria1:=WS.Cells(A, 26)
Workbooks.Add
WS.Range("A1:Y" & LR).Copy
ActiveSheet.Range("A1").Select
ActiveSheet.Paste
ActiveSheet.Name = WS.Cells(A, 26)
Columns("Z:AA") = vbNullString
'ActiveWorkbook.SaveAs Filename:=WS.Cells(A, 27) & " - LSA 2023"
Dim path As String
path = GetPath & ""
ActiveWorkbook.SaveAs path & WS.Cells(A, 27) & Year & ".xlsx", FileFormat:=xlOpenXMLWorkbook
ActiveSheet.Columns("A:Z").AutoFit
ActiveWorkbook.Save
ActiveWorkbook.Close
Next A
ThisWorkbook.Activate
WS.AutoFilterMode = False
MsgBox "workbooks have been generated successfully"
Sheets(1).Select
End If
End With
AnswerYes = MsgBox("Do you wish to set a Password?", vbQuestion + vbYesNo, "User Repsonse")
If AnswerYes = vbYes Then
Setpassword = InputBox("Please enter the password.")
AddPassword path, Setpassword
MsgBox "Password successfully set in all worksheets!"
Else
MsgBox ("Okay, no password is required to open the worksheets")
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
-------------------------------------------------------------
I have an existing macro that filters based on a user selected column from a worksheet. For example, if the column data has "20 departments", the macro will do an auto filter and generate 20 worksheets for each department.
So I will have Dept A.xls, Dept B.xls, Dept C.xls and so on (depending on how many departments listed in that particular column within the master data worksheet).
My issue is that the generated worksheets s/no number is no longer in sequence.
How do I add in the necessary vba code to correct the S/N number so that it runs 1, 2, 3, 4...in column A3 onwards for all generated worksheets?
Appreciate your help! thanks
Below is the VB code that generates the worksheets:
-------------------------------------------------------------
Sub S_Frm()
'Disbale screen updating for speedup macros working
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
'Application.Calculation = xlCalculationManual
On Error Resume Next
Dim GetPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show <> 0 Then
GetPath = .SelectedItems(1)
'Variables for worksheet , lastrow & lastcolumn of database
Dim WS As Worksheet, LR As Long, LC As Long, IB As String, SColmn As String, LastSheet As Long, Year As String, columnName As String, AnswerYes As String, AnswerNo As String, Setpassword As String, columnNumber As Integer
Set WS = ThisWorkbook.Sheets("Master")
LR = WS.Range("A" & Rows.Count).End(xlUp).Row
LC = WS.Cells(3, Columns.Count).End(xlToLeft).Column
WS.Activate
IB = Application.InputBox("Please select the column you want to split data based on")
SColumn = "" & IB & ":" & IB & ""
WS.Range(SColumn).Copy: WS.Columns("Z:Z").PasteSpecial xlPasteValues
LastSheet = WS.Range("Z" & Rows.Count).End(xlUp).Row
WS.Range("AA3").Formula = "=SUBSTITUTE(RC[-1],""/"",""-"")"
WS.Range("AA3").AutoFill Destination:=Range("AA3:AA" & LastSheet)
WS.Columns("Z:AA").RemoveDuplicates Columns:=1, Header:=xlYes
WS.Columns("AA:AA").Copy: WS.Columns("AA:AA").PasteSpecial xlPasteValues
LastSheet = WS.Range("Z" & Rows.Count).End(xlUp).Row
Year = InputBox("Please enter the words you want to add to the filename.")
columnName = SColumn
columnNumber = Range(columnName).Column
For A = 4 To LastSheet
WS.Cells(3, SColumn).AutoFilter Field:=columnNumber, Criteria1:=WS.Cells(A, 26)
Workbooks.Add
WS.Range("A1:Y" & LR).Copy
ActiveSheet.Range("A1").Select
ActiveSheet.Paste
ActiveSheet.Name = WS.Cells(A, 26)
Columns("Z:AA") = vbNullString
'ActiveWorkbook.SaveAs Filename:=WS.Cells(A, 27) & " - LSA 2023"
Dim path As String
path = GetPath & ""
ActiveWorkbook.SaveAs path & WS.Cells(A, 27) & Year & ".xlsx", FileFormat:=xlOpenXMLWorkbook
ActiveSheet.Columns("A:Z").AutoFit
ActiveWorkbook.Save
ActiveWorkbook.Close
Next A
ThisWorkbook.Activate
WS.AutoFilterMode = False
MsgBox "workbooks have been generated successfully"
Sheets(1).Select
End If
End With
AnswerYes = MsgBox("Do you wish to set a Password?", vbQuestion + vbYesNo, "User Repsonse")
If AnswerYes = vbYes Then
Setpassword = InputBox("Please enter the password.")
AddPassword path, Setpassword
MsgBox "Password successfully set in all worksheets!"
Else
MsgBox ("Okay, no password is required to open the worksheets")
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
-------------------------------------------------------------
