Question

这是我的挑战。我尝试将基于货币和日期的数据复制并粘贴到同一工作簿中新创建的工作表。每个新创建的工作表应按主要来源的货币和日期命名。我被日期困住了，我不知道如何添加其他货币。请指教。非常感谢你。

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

'在启动宏之前清理以前的数据 Application.DisplayAlerts = False 对于每个我在ActiveWorkbook.Worksheets中如果i.name =“Draft_Data”那么i.Delete 接下来我

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


Application.DisplayAlerts = True

'创建草稿表以处理数据表（ “JE_data”）。选择表格（“JE_data”）。复制之后：=表格（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

'复制货币和日期数据以查找唯一数据 '这取决于您的数据结构，最初的假设是C列是货币，D列是交易日期 '实际数据结构不同 - 货币是列“P”，日期是列“W”， '所以我必须删除它们之间的列

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

'选择草稿表并开始过滤 draft.Select ActiveSheet.ListObjects.Add（xlSrcRange，Range（“$ A $ 1：$ W $”＆amp; 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

Answer 1

我不知道你的数据是什么样的，所以我使用如下的简单数据：

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

我的想法是创建一个唯一值列表（货币，交易日期），然后使用过滤器获取带有2个标准的数据：货币和数据。不管你有多少行，它应该是一样的。

将过滤后的数据复制到新工作表，并将此工作表重命名为DATE＆amp;货币视需要。

当我测试时，这非常有效

（我还没有清理我的代码，所以请根据需要进行修改）

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日期和货币条件，用于将数据复制并粘贴到按日期和货币命名的已添加工作表

1 个答案: