将数据从一个excel表格排序到其他几个

Question

编程时，我完全无能为力，因此我在这里寻找一些帮助。

我有几个工作表中的书，每一种都有一个库存项目和常见的一种，它显示谁的项目去了。见下面的例子：

通用片

Date |Code |Name  |Reason|Item 1|Item 2|Item 3|Item 4| 
1-may|ABC001|John Smith|Call |1  |  |2  |1  | 
2-may|CAA002|Mary Jane |New |  |2  |2  |  | 

项目1张

Date |Code |Name  |Reason|Used| 
1-may|ABC001|John Smith|Call |1 | 

我需要做的，是填充在每天主要的一个单独项目表基础。即约翰将被输入项目1,3和4的床单，玛丽将在项目2和3上。

有没有办法做到这一点？

在此先感谢！

Answer 1

我已经测试过，并得到这个主要是工作，你可能需要做一些修改，使表的名称相匹配了他们在工作簿什么，也我不完全知道如何仅复制某些列（代码下面将复制整行）

Sub ConsolidateX() 

Dim ws As Worksheet, wsItem1 As Worksheet, wsItem2 As Worksheet 'set ws"Name" to the sheet names in your workbook, define all worksheets that you are going to copy to 
Dim lrow As Long, rng As Range 
Dim tdate As Date 

tdate = Date 

Set wsItem1 = ThisWorkbook.Sheets("Item 1") 
Set wsItem2 = ThisWorkbook.Sheets("Item 2") 'make sure you set all of your worksheet names for all of the items you wish to copy for 

With Application 
.ScreenUpdating = False 
.DisplayAlerts = False 
End With 

With ActiveSheet 
    lrow = .Range("A" & .Rows.Count).End(xlUp).Row 
    .AutoFilterMode = False 
    .Range("A2:I" & lrow).AutoFilter Field:=1, Criteria1:="<" & tdate 'Leave this line in here to first filter for todays date (to prevent you from copying over old data 
    .Range("A2:I" & lrow).AutoFilter Field:=3, Criteria1:="<>" 'change the field # to reflect what column you are checking to make sure is not blank 
    .Range("A3:I" & lrow).SpecialCells(xlCellTypeVisible).EntireRow.Copy 
    wsItem1.Range("A" & wsItem1.Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues 
.AutoFilterMode = False 
Application.CutCopyMode = False 
.Range("A2:I" & lrow).AutoFilter Field:=1, Criteria1:="<" & tdate 
.Range("A2:I" & lrow).AutoFilter Field:=4, Criteria1:="<>" 'just continue to copy this repeated part of code down for as many Items as you are trying to filter for remembering to change the Autofilter Field # and copy location 
.Range("A3:I" & lrow).SpecialCells(xlCellTypeVisible).EntireRow.Copy 
wsItem2.Range("A" & wsItem2.Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues 
.AutoFilterMode = False 
Application.CutCopyMode = False 
End With 

With Application 
.ScreenUpdating = True 
.DisplayAlerts = True 
End With 

End Sub 

我测试了一个空白工作簿和一些虚拟数据，因此它应该没关系，只要你改变所有的名字和事情，以满足您的工作簿。 另外请确保您从主表单运行此宏，因为它只会应用过滤器并从您当前所在的工作表进行复制。

对不起，我不知道如何复制行像你打算，但这应该是一个很好的起点。