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



Reply With Quote