VBA Date and Currency conditions to copy and paste data to added sheets named by Date and Currency

Question

Here is my challenge. I try to copy and paste data based on Currency and Dates to a newly created Worksheets in the same Workbook. Each newly created Worksheet should be named by Currency and Date from the main source. I am stuck with dates and I am not sure how to add other currencies. Please advise. Thank you very much.

Option Explicit

Sub Create_Copy_of_JE_DATA_Split_By_Currency_AND_By_Date()

Dim draft As Worksheet
Dim curr_date As Worksheet
Dim LastRow
Dim LastColumn As Integer
Dim i
Dim drafttable As Object
Dim Curr As String
Dim transdate As Date

'Clean up previous data before start the macro Application.DisplayAlerts = False For Each i In ActiveWorkbook.Worksheets If i.name = "Draft_Data" Then i.Delete Next i

For Each i In ActiveWorkbook.Worksheets
    If i.name = "Currency_Date" Then i.Delete
Next i


Application.DisplayAlerts = True

'Create a draft sheet to work with data Sheets("JE_data").Select Sheets("JE_data").Copy After:=Sheets(Sheets.count)

ActiveSheet.name = "Draft_Data"

Set draft = Sheets("Draft_Data")

LastRow = draft.Range("A1").End(xlDown).End(xlDown).End(xlUp).Row

LastColumn = draft.Range("A1").End(xlToRight).Column

'Copy Currency and Date data to find unique data 'It depends on your data structure, the original assumption was that column C is currency and column D is transaction Date 'The actual data structure is different - Currency is Column "P" and Date is Column "W", 'so I would have to delete Columns between them

Range("P2:W" & LastRow).Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.count)
ActiveSheet.name = "Currency_Date"

Set curr_date = Sheets("Currency_Date")

ActiveSheet.Paste

Application.CutCopyMode = False

With Sheets("Currency_Date")

    .Columns("B:G").EntireColumn.Delete
    .Range("$A$1:$B$" & LastRow).RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo

End With

'ActiveSheet.Range("$A$1:$B$" & LastRow).RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo

'Select Draft sheet and start filtering draft.Select ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$W$" & LastRow), , xlYes).name = "Draft_table"

'so when I filter it, it will have the same format.
'it's upto you to choose the date format, :) I'm in Australia so I choose d/mm/yyyy
Columns("W:W").Select
Selection.NumberFormat = "d/mm/yyyy;@"

Set drafttable = draft.ListObjects("Draft_table")


'The idea is for each unique value of currency and date pair, we will filter this Draft 'table
'and copy the result to a new sheet then rename this sheet.
For i = 1 To Sheets("Currency_Date").Range("A1").End(xlDown).End(xlDown).End(xlUp).Row
    Curr = curr_date.Range("A" & i).Value
    transdate = curr_date.Range("B" & i).Value

    draft.Select

    drafttable.Range.AutoFilter Field:=16, Criteria1:=Curr
    drafttable.Range.AutoFilter Field:=23, Criteria1:=transdate

    drafttable.Range.AutoFilter Field:=23, Criteria1:="=" & transdate, Operator:=xlAnd


    Range("Draft_table").SpecialCells(xlCellTypeVisible).Select

    Selection.Copy
    Sheets.Add After:=Sheets(Sheets.count)
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
    xlNone, SkipBlanks:=False, Transpose:=False

    ActiveSheet.name = Format(transdate, "MMM DD YYYY") & " " & Curr

    Sheets("JE_Data").Select
    Rows("1:1").Select
    Selection.Copy

    Sheets(Format(transdate, "MMM DD YYYY") & " " & Curr).Select
    Rows("1:1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Cells.EntireColumn.AutoFit

    'Prepare for next filter.
    draft.ShowAllData
Next i

'draft.Delete 'curr_date.Delete

End Sub

Harry Duong Harry Duong · Accepted Answer · 2014-09-04T09:00:42

I don't know how your data look like, so I use a simple data like below:

ID  Name    Currency    Transaction_Date
1   A       AUD         1/08/2014
2   B       USD         2/08/2014
3   C       GBP         4/08/2014
4   D       JPY         10/09/2014
5   E       AUD         4/08/2014
6   F       USD         10/09/2014
7   A       GBP         1/08/2014
8   B       JPY         2/08/2014
9   C       AUD         4/08/2014
10  D       USD         10/09/2014

My idea is create a list of unique value (Currency,Transaction date), then using filter to get data with 2 criterial: Currency and Data. Doesn't matter how many rows you have, it should work the same.

Copy the filtered data to new sheet and rename this sheet to DATE & Currency as required.

When I test, this works perfectly

(I have not clean my code yet, so please modify it as you need)

Sub Create_Copy_of_JEDATA()

Dim draft, curr_date As Worksheet
Dim LastRow, LastColumn As Integer

'Clean up previous data before start the macro
    Application.DisplayAlerts = False
    For Each i In ActiveWorkbook.Worksheets
        If i.Name = "Draft_Data" Then i.Delete
    Next i

    For Each i In ActiveWorkbook.Worksheets
        If i.Name = "Currency_Date" Then i.Delete
    Next i


    Application.DisplayAlerts = True


'Create a draft sheet to work with data
    Sheets("JE_data").Select
    Sheets("JE_data").Copy After:=Sheets(Sheets.Count)

    ActiveSheet.Name = "Draft_Data"

    Set draft = Sheets("Draft_Data")

    LastRow = draft.Range("A1").End(xlDown).End(xlDown).End(xlUp).Row

    LastColumn = draft.Range("A1").End(xlToRight).Column



'Copy Currency and Date data to find unique data
'Depend on your data structure, I assume that column C is currency and column D is transaction Date
    Range("C2:D" & LastRow).Select
    Selection.Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "Currency_Date"

    Set curr_date = Sheets("Currency_Date")

    ActiveSheet.Paste

    Application.CutCopyMode = False

    ActiveSheet.Range("$A$1:$B$" & LastRow).RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo

'Select Draft sheet and start filtering
    draft.Select
    ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$D$" & LastRow), , xlYes).Name = "Draft_table"

    'so when I filter it, it will have the same format.
    'it's upto you to choose the date format, :) I'm in Australia so I choose d/mm/yyyy
    Columns("D:D").Select
    Selection.NumberFormat = "d/mm/yyyy;@"

    Set DraftTable = draft.ListObjects("Draft_table")


    'The idea is for each unique value of currency and date pair, we will filter this Draft table
    'and copy the result to a new sheet then rename this sheet.
    For i = 1 To Sheets("Currency_Date").Range("A1").End(xlDown).End(xlDown).End(xlUp).Row
        Curr = curr_date.Range("A" & i).Value
        transdate = curr_date.Range("B" & i).Value

        draft.Select

        DraftTable.Range.AutoFilter Field:=3, Criteria1:=Curr

        DraftTable.Range.AutoFilter Field:=4, Criteria1:="=" & transdate, Operator:=xlAnd


        Range("Draft_table").SpecialCells(xlCellTypeVisible).Select

        Selection.Copy
        Sheets.Add After:=Sheets(Sheets.Count)
        Range("A2").Select
        Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False

        ActiveSheet.Name = Format(transdate, "MMM DD YYYY") & " " & Curr

        Sheets("JE_Data").Select
        Rows("1:1").Select
        Selection.Copy

        Sheets(Format(transdate, "MMM DD YYYY") & " " & Curr).Select
        Rows("1:1").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False

        Cells.EntireColumn.AutoFit

        'Prepare for next filter.
        draft.ShowAllData
    Next i

'draft.Delete
'curr_date.Delete

End Sub

VBA Date and Currency conditions to copy and paste data to added sheets named by Date and Currency

1 Answers