Vancylynn
08-18-2021, 06:34 AM
Hi
Can anyone help me to correct the coding error? I am having the problem cannot stop the last row copy & save in new file. Coding highlight in red color.
My purpose to this macro is to split the data in "pivot" tab into multiple workbook based on currency and split again into multiple worksheet by recipient name in the currency file. Then save the file name as USD and MYR. Result is in each currency file will have different recipient name in multiple worksheet.
Thank you for help.
----------------------------------------------------------------------------------------
Sub split_Currency_in_workbooks()
Application.ScreenUpdating = False
Dim currency_sh As Worksheet
Set currency_sh = ThisWorkbook.Sheets("Pivot")
Dim summary_sh As Worksheet
Set summary_sh = ThisWorkbook.Sheets("Summary")
Dim nwb As Workbook
Dim nsh As Worksheet
'Get the currency split
summary_sh.Range("A:A").Clear
currency_sh.AutoFilterMode = False
currency_sh.Range("K:K").Copy summary_sh.Range("A1")
summary_sh.Range("A:A").RemoveDuplicates 1, xlYes
Dim i As Integer
For i = 2 To Application.CountA(summary_sh.Range("A:A"))
currency_sh.UsedRange.AutoFilter 11, summary_sh.Range("A" & i).Value
Set nwb = Workbooks.Add
Set nsh = nwb.Sheets(1)
currency_sh.UsedRange.SpecialCells(xlCellTypeVisible).Copy nsh.Range("A1")
nsh.UsedRange.EntireColumn.ColumnWidth = 15
' Split by requester
'Sub SplitRequester()
'Declaring constant variables
Const col = "A"
Const header_row = 1
'Assigning initial value as 2, because data transfer will happen from 2nd row onwards
Const starting_row = 2
'To declare variable of worksheet type for main sheet, that has data to split
Dim source_sheet As Worksheet
'To declare variable of worksheet type for adding required sheets
Dim destination_sheet As Worksheet
Dim source_row As Long
Dim last_row As Long
Dim destination_row As Long
'This variable is for changing values in column A, that has recipeint name
Dim recipient As String
'Assigning active sheet, that has data to split
Set source_sheet = ActiveSheet
'To know the last filled row and activesheet basis on column A, that has data to split
last_row = source_sheet.Cells(source_sheet.Rows.Count, col).End(xlUp).Row
For source_row = starting_row To last_row
recipient = source_sheet.Cells(source_row, col).Value
Set destination_sheet = Nothing
On Error Resume Next
Set destination_sheet = Worksheets(recipient)
On Error GoTo 0
If destination_sheet Is Nothing Then
'To add new sheet, if there is no existing sheet of the given recipient name
Set destination_sheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
'To assign name to added sheet
destination_sheet.Name = recipient
'To add header row to each added sheet
source_sheet.Rows(header_row).Copy Destination:=destination_sheet.Rows(header_row)
End If
'To identify the next available row on destination sheet
destination_row = destination_sheet.Cells(destination_sheet.Rows.Count, col).End(xlUp).Row + 1
'Coying rows from active sheet, one by one and pasting to next available line on destination sheet
source_sheet.Rows(source_row).Copy Destination:=destination_sheet.Rows(destination_row)
Next source_row
nwb.SaveAs summary_sh.Range("H6").Value & "/" & summary_sh.Range("A" & i).Value & ".xlsx"
nwb.Close False
currency_sh.AutoFilterMode = False
summary_sh.Range("A:A").Clear
MsgBox "Done"
Next
End Sub
Can anyone help me to correct the coding error? I am having the problem cannot stop the last row copy & save in new file. Coding highlight in red color.
My purpose to this macro is to split the data in "pivot" tab into multiple workbook based on currency and split again into multiple worksheet by recipient name in the currency file. Then save the file name as USD and MYR. Result is in each currency file will have different recipient name in multiple worksheet.
Thank you for help.
----------------------------------------------------------------------------------------
Sub split_Currency_in_workbooks()
Application.ScreenUpdating = False
Dim currency_sh As Worksheet
Set currency_sh = ThisWorkbook.Sheets("Pivot")
Dim summary_sh As Worksheet
Set summary_sh = ThisWorkbook.Sheets("Summary")
Dim nwb As Workbook
Dim nsh As Worksheet
'Get the currency split
summary_sh.Range("A:A").Clear
currency_sh.AutoFilterMode = False
currency_sh.Range("K:K").Copy summary_sh.Range("A1")
summary_sh.Range("A:A").RemoveDuplicates 1, xlYes
Dim i As Integer
For i = 2 To Application.CountA(summary_sh.Range("A:A"))
currency_sh.UsedRange.AutoFilter 11, summary_sh.Range("A" & i).Value
Set nwb = Workbooks.Add
Set nsh = nwb.Sheets(1)
currency_sh.UsedRange.SpecialCells(xlCellTypeVisible).Copy nsh.Range("A1")
nsh.UsedRange.EntireColumn.ColumnWidth = 15
' Split by requester
'Sub SplitRequester()
'Declaring constant variables
Const col = "A"
Const header_row = 1
'Assigning initial value as 2, because data transfer will happen from 2nd row onwards
Const starting_row = 2
'To declare variable of worksheet type for main sheet, that has data to split
Dim source_sheet As Worksheet
'To declare variable of worksheet type for adding required sheets
Dim destination_sheet As Worksheet
Dim source_row As Long
Dim last_row As Long
Dim destination_row As Long
'This variable is for changing values in column A, that has recipeint name
Dim recipient As String
'Assigning active sheet, that has data to split
Set source_sheet = ActiveSheet
'To know the last filled row and activesheet basis on column A, that has data to split
last_row = source_sheet.Cells(source_sheet.Rows.Count, col).End(xlUp).Row
For source_row = starting_row To last_row
recipient = source_sheet.Cells(source_row, col).Value
Set destination_sheet = Nothing
On Error Resume Next
Set destination_sheet = Worksheets(recipient)
On Error GoTo 0
If destination_sheet Is Nothing Then
'To add new sheet, if there is no existing sheet of the given recipient name
Set destination_sheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
'To assign name to added sheet
destination_sheet.Name = recipient
'To add header row to each added sheet
source_sheet.Rows(header_row).Copy Destination:=destination_sheet.Rows(header_row)
End If
'To identify the next available row on destination sheet
destination_row = destination_sheet.Cells(destination_sheet.Rows.Count, col).End(xlUp).Row + 1
'Coying rows from active sheet, one by one and pasting to next available line on destination sheet
source_sheet.Rows(source_row).Copy Destination:=destination_sheet.Rows(destination_row)
Next source_row
nwb.SaveAs summary_sh.Range("H6").Value & "/" & summary_sh.Range("A" & i).Value & ".xlsx"
nwb.Close False
currency_sh.AutoFilterMode = False
summary_sh.Range("A:A").Clear
MsgBox "Done"
Next
End Sub