Hi i want to save all the excel output files in same
folder ,i have a vba code but the files are not saving in the folder. The file should be saved in the format with first 5 digits in F column that is (example 1396A) format
01_03_1396A_yyyymmdd
VBA CODE
Sub SplitSheetIntoMultipleSheetsBasedOnColumn()
Dim objWorksheet As Excel.Worksheet
Dim nLastRow, nRow, nNextRow As Integer
Dim strColumnValue As String
Dim objDictionary As Object
Dim varColumnValues As Variant
Dim varColumnValue As Variant
Dim objSheet As Excel.Worksheet
Dim FPath As String
Set objWorksheet = ActiveSheet
nLastRow = objWorksheet.Range("F" & objWorksheet.Rows.Count).End(xlUp).Row
Set objDictionary = CreateObject("Scripting.Dictionary")
For nRow = 2 To nLastRow
strColumnValue = objWorksheet.Range("A" & nRow).Value
If objDictionary.Exists(strColumnValue) = False Then
objDictionary.Add strColumnValue, 1
End If
Next
varColumnValues = objDictionary.Keys
For i = LBound(varColumnValues) To UBound(varColumnValues)
varColumnValue = varColumnValues(i)
Set objSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
objSheet.Name = varColumnValue
objWorksheet.Rows(1).EntireRow.Copy objSheet.Rows(1)
For nRow = 2 To nLastRow
If CStr(objWorksheet.Range("F" & nRow).Value) = CStr(varColumnValue) Then
objWorksheet.Rows(nRow).EntireRow.Copy
nNextRow = objSheet.Range("A" & objSheet.Rows.Count).End(xlUp).Row + 1
objSheet.Range("A" & nNextRow).PasteSpecial xlPasteValuesAndNumberFormats
End If
FPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Sheets
ws.Copy
Application.ActiveWorkbook.SaveAs Filename:=FPath & "\" & ws.Name & ".xlsx"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Next
objSheet.Columns("A:H").AutoFit
Next
End Sub
01_03_1396A_yyyymmdd
VBA CODE
Sub SplitSheetIntoMultipleSheetsBasedOnColumn()
Dim objWorksheet As Excel.Worksheet
Dim nLastRow, nRow, nNextRow As Integer
Dim strColumnValue As String
Dim objDictionary As Object
Dim varColumnValues As Variant
Dim varColumnValue As Variant
Dim objSheet As Excel.Worksheet
Dim FPath As String
Set objWorksheet = ActiveSheet
nLastRow = objWorksheet.Range("F" & objWorksheet.Rows.Count).End(xlUp).Row
Set objDictionary = CreateObject("Scripting.Dictionary")
For nRow = 2 To nLastRow
strColumnValue = objWorksheet.Range("A" & nRow).Value
If objDictionary.Exists(strColumnValue) = False Then
objDictionary.Add strColumnValue, 1
End If
Next
varColumnValues = objDictionary.Keys
For i = LBound(varColumnValues) To UBound(varColumnValues)
varColumnValue = varColumnValues(i)
Set objSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
objSheet.Name = varColumnValue
objWorksheet.Rows(1).EntireRow.Copy objSheet.Rows(1)
For nRow = 2 To nLastRow
If CStr(objWorksheet.Range("F" & nRow).Value) = CStr(varColumnValue) Then
objWorksheet.Rows(nRow).EntireRow.Copy
nNextRow = objSheet.Range("A" & objSheet.Rows.Count).End(xlUp).Row + 1
objSheet.Range("A" & nNextRow).PasteSpecial xlPasteValuesAndNumberFormats
End If
FPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Sheets
ws.Copy
Application.ActiveWorkbook.SaveAs Filename:=FPath & "\" & ws.Name & ".xlsx"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Next
objSheet.Columns("A:H").AutoFit
Next
End Sub