EXCEL批量从多个数据表中按条件摘取数据的方法

从多个表中摘取数据到新的工作表中的方法
目标：
从多张以年份为依据划分的采购状态表中，摘取出专用备件，创建一张新的专用备件清单表。
实现过程介绍：

1. 采购状态表按从左到右顺序，依次由这些字段构成：序号（A3），采购状态（B3），采购单号（C3），品名（D3），规格（E3），品牌（F3）,数量（G3）,单价（H3），总价（I3），供应商（J3），费用中心（K3），应用设备（L3），采购月份（M3），采购日期（N3），到货日期（O3），是否专用（P3），备件等级（Q3），安全库存（R3），备注（领用记录）（S3）。专用备件清单表由序号（A2），名称(B2)，规格(C2)，品牌(D2)，单价(E2)，总价(F2)，费用中心(G2)，应用设备(H2)，最后入库日期(I2)，备件等级(J2)，安全库存(K2)，备注(L2)这些字段构成。。
2. 如果专用备件清单表中有这个被选中名称的备件存在，则专用备件清单表中备件的数量加上采购状态表中被选中备件的数量；专用备件清单表中的单价更新为采购状态表中被选中备件的单价；入库日期更新为源数据的到货日期；备件等级，安全库存数据更新为采购状态表中被选中备件的相关信息；领用记录的内容添加一个“/”符号后添加上采购状态表中被选中备件行的备注信息。
3. 如果选中的备件在专用备件清单表中没有同名备件，则新增一行数据，数据取自采购状态表中相对应的字段。
4. 专用备件清单表中的序号，除首行记录的序号为直接赋值成1，其它行的数据的序号为上一行记录的序号加1。专用备件清单表中的总价，为本表内的单价与数量的乘积。
5. 设置两种数据转移模式，一种是单个备件转移，程序代码见模块一，即选择备件品名单元格后，单击调用“添加单个备件（）”宏的控件（可以是按钮，也可以是图标）；一种是选中工作表内符合要求的备件整批转移，程序代码见模块二，即激活工作表后，点击调用“批量添加备件()”宏的控件（可以是按钮，也可以是图标）。
6. 额外功能，在专用备件清单表中，计数备注单元格中“/”符号的数量，可以知道此备件一共有多少笔采购。
   模块一：
   Sub 添加单个备件()
   Dim i, m As Integer
   Dim rn As Range
   Dim cur_row As Integer
   Dim lastrow As Integer
   Dim wks As Worksheet
   Set rn = ActiveCell
   Set wks = Sheets(“专用备件清单”)
   cur_row = rn.Row
   lastrow = wks.UsedRange.Rows.Count
   m = lastrow + 1
   For i = 1 To lastrow
   If rn.Value = wks.Cells(i, 2).Value Then
   wks.Cells(i, 5).Value = wks.Cells(i, 5).Value + ActiveSheet.Cells(cur_row, 7).Value
   wks.Cells(i, 6).Value = ActiveSheet.Cells(cur_row, 8).Value '更新单价
   wks.Cells(i, 7) = wks.Cells(i, 5) * wks.Cells(i, 6) '更新总价
   wks.Cells(i, 12).Value = ActiveSheet.Cells(cur_row, 15).Value '更新最后入库日期
   wks.Cells(i, 13).Value = wks.Cells(i, 13).Value & “/” & ActiveSheet.Cells(cur_row, 19).Value '领用记录
   Set rn = Nothing
   Set wks = Nothing
   Exit Sub
   End If
   Next i
   If m = 3 Then
   wks.Cells(m, 1) = 1 '首行序号置1
   Else
   wks.Cells(m, 1) = wks.Cells(lastrow, 1) + 1 '序号加1
   End If
   ActiveSheet.Cells(cur_row, 4).Copy wks.Cells(m, 2) '名称
   ActiveSheet.Cells(cur_row, 5).Copy wks.Cells(m, 3) '规格
   ActiveSheet.Cells(cur_row, 6).Copy wks.Cells(m, 4) '品牌
   ActiveSheet.Cells(cur_row, 7).Copy wks.Cells(m, 5) '数量
   ActiveSheet.Cells(cur_row, 8).Copy wks.Cells(m, 6) '最后一次采购单价
   wks.Cells(m, 7) = wks.Cells(m, 5) * wks.Cells(m, 6) '总价
   ActiveSheet.Cells(cur_row, 11).Copy wks.Cells(m, 8) '费用中心
   ActiveSheet.Cells(cur_row, 12).Copy wks.Cells(m, 9) '对应设备
   ActiveSheet.Cells(cur_row, 17).Copy wks.Cells(m, 10) '安全等级
   ActiveSheet.Cells(cur_row, 18).Copy wks.Cells(m, 11) '安全库存量
   ActiveSheet.Cells(cur_row, 15).Copy wks.Cells(m, 12) '入库日期
   wks.Cells(m, 13).Value = wks.Cells(m, 13).Value & “/” & ActiveSheet.Cells(cur_row, 19).Value '领用记录

Set rn = Nothing
Set wks = Nothing
End Sub

模块二：
Sub 批量添加备件()
Dim i, j, m, cunzai As Integer
Dim actshtrow,lastrow As Integer
Dim wksAct As Worksheet
Dim wks As Worksheet
Set wksAct = ActiveSheet
Set wks = Sheets(“专用备件清单”)
actshtrow = wksAct.Range(“D3”).End(xlDown).Row
For j = 4 To actshtrow
If wksAct.Cells(j, 16).Value = “专用” Then
cunzai = 0
lastrow = wks.UsedRange.Rows.Count
m = lastrow + 1
For i = 1 To lastrow
If wksAct.Cells(j, 4).Value = wks.Cells(i, 2).Value Then
cunzai = 1 '发现同名备件
wks.Cells(i, 5).Value = wks.Cells(i, 5).Value + wksAct.Cells(j, 7).Value '库存数量累加
wks.Cells(i, 6).Value = wksAct.Cells(j, 8).Value '更新单价
wks.Cells(i, 7) = wks.Cells(i, 5) * wks.Cells(i, 6) '更新单价
wks.Cells(i, 12).Value = wksAct.Cells(j, 15).Value '更新最后入库日期
wks.Cells(i, 13).Value = wks.Cells(i, 13).Value & “/” & wksAct.Cells(j, 19).Value '领用记录
i = lastrow + 1 '退出内循环
End If
Next i
If cunzai = 0 Then '如果在"专用备件清单"表内没有找到相同名称的备件，则新增一行。
If m = 3 Then
wks.Cells(m, 1) = 1 '首行序号置1
Else
wks.Cells(m, 1) = wks.Cells(lastrow, 1) + 1 '序号加1
End If
wksAct.Cells(j, 4).Copy wks.Cells(m, 2) '名称
wksAct.Cells(j, 5).Copy wks.Cells(m, 3) '规格
wksAct.Cells(j, 6).Copy wks.Cells(m, 4) '品牌
wksAct.Cells(j, 7).Copy wks.Cells(m, 5) '数量
wksAct.Cells(j, 8).Copy wks.Cells(m, 6) '最后一次采购单价
wks.Cells(m, 7) = wks.Cells(m, 5) * wks.Cells(m, 6) '总价
wksAct.Cells(j, 11).Copy wks.Cells(m, 8) '费用中心
wksAct.Cells(j, 12).Copy wks.Cells(m, 9) '对应设备
wksAct.Cells(j, 17).Copy wks.Cells(m, 10) '安全等级
wksAct.Cells(j, 18).Copy wks.Cells(m, 11) '安全库存量
wksAct.Cells(j, 15).Copy wks.Cells(m, 12) '入库日期
wks.Cells(m, 13).Value = wks.Cells(m, 13).Value & “/” & wksAct.Cells(j, 19) '领用记录
End If
End If
Next j
Set wksAct = Nothing
Set wks = Nothing
End Sub