VBAdate和货币条件将数据复制并粘贴到按date和货币命名的添加图纸中

这是我的挑战。 我尝试将基于货币和date的数据复制并粘贴到同一工作簿中新创build的工作表。 每个新创build的工作表都应该使用来自主要来源的货币和date来命名。 我与date卡住，我不知道如何添加其他货币。 请指教。 非常感谢你。

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 

'在启动macros之前清理以前的数据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 

（“JE_data”）。select表格（“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 

'复制货币和date数据来find唯一的数据'这取决于你的数据结构，原来的假设是列C是货币，列D是交易date'实际的数据结构是不同的 – 货币是列“P”和date是列“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 

'select草稿表并开始过滤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

结束小组

Answer 1

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

 ID名称货币Transaction_Date
 1澳元2014年8月1日
 2 B USD 2/08/2014
 3 C GBP 4/08/2014
 4 D日元10/09/2014
 5 E AUD 4/08/2014
 6 F USD 10/09/2014
 7英镑1/08/2014
 8 B日元2/08​​/2014
 9 C AUD 4/08/2014
 10 D USD 10/09/2014

我的想法是创build一个独特的价值（货币，交易date）的列表，然后使用filter来获取数据与2条准则：货币和数据。 无论你有多less行，它应该是一样的。

将过滤的数据复制到新工作表，并根据需要将此工作表重命名为DATE＆Currency。

当我testing，这完美的作品

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

 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