关于EXCEL多个子表复制到另一个EXCEL对应子表
需要将附件中《数据源》里面的数据从表三开始往后的子表,数量列非空白项复制到《复制模板》里面,最总形成《成果》样式的表格,每天都是重复粘贴复制,有没有快速解决的办法
学习软件.rar
(1.39 MB)
Attribute VB_Name = "copySheet" '运行前, 数据源 和 【复制模板】 必须同时打开 !! Public Function cpSht2Sht(ByVal iColflag As Integer, _ iStartRow As Integer, iStartRow2 As Integer, _ cSurSht As String, cTarSht As String, _ ByRef arrColist) As Boolean ' 共用模块,拷贝Sheet间数据 ' 参数说明:非零标志位 ,起始行,源Sheet,目标Sheet ,列对应数组. ' 为了简捷,这里省略了Error 处理语句,用户可以自己添加上. Dim sht0 As Worksheet, sht1 As Worksheet Dim iArrRow As Integer, iLastCol As Integer, iLastRow As Integer Dim irow As Integer, icol As Integer Dim arrData() iArrRow = UBound(arrColist, 1) iLastCol = arrColist(iArrRow, 0) '获取终止列,至于起始列,默认是 arrColist(0, 0) Set sht0 = Workbooks("数据源.xls").Worksheets(cSurSht) Set sht1 = Workbooks("【复制模板】.xlsx").Worksheets(cTarSht) '获取终止行 ,起始行则由参数2获取. sht0.Activate iLastRow = sht0.UsedRange.Rows.Count arrData = sht0.Range(Cells(iStartRow, arrColist(0, 0)), Cells(iLastRow, iLastCol)).Value '开始输出数据 sht1.Activate For irow = 1 To UBound(arrData, 1) If arrData(irow, iColflag) <> 0 And arrData(irow, iColflag) <> "." Then For icol = 0 To iArrRow sht1.Cells(iStartRow2, arrColist(icol, 1)).Value = arrData(irow, icol + 1) Next icol iStartRow2 = iStartRow2 + 1 ' 目标表的起始输入行. End If Next irow ReDim arrData(0, 0) cpSht2Sht = True End Function Sub CopySht() Dim rlt As Boolean Dim 参数1 As Integer, 参数2 As Integer, 参数3 As Integer Dim 参数4 As String, 参数5 As String '调用cpSht2Sht示例 '比如要把数据源的[表三甲]复制到模块的的[表三甲]中去,那么: '数据源的[表三甲]的第5列非零时,需要复制,所以参数1 = 5 参数1 = 5 '从数据源的[表三甲]的第8行开始复制,所以参数2=8 参数2 = 8 '从目标表的[表三甲]的第8行开始输出,所以参数3=8 参数3 = 8 '源表名称:"表三甲",所以参数4="表三甲" 参数4 = "表三甲" '目标表名称:"表三甲",所以参数5="表三甲" 参数5 = "表三甲" '接下来,需要定义源表与目标表之间的列对应关系(参数6,是一个数组) '由于有7列数列需要复制,故定义数组为7行,2列: Dim arr1(6, 1) As Integer arr1(0, 0) = 1: arr1(0, 1) = 2 '源表第1列,复制到目标表第2列 arr1(1, 0) = 2: arr1(1, 1) = 3 '源表第2列,复制到目标表第3列 arr1(2, 0) = 3: arr1(2, 1) = 4 '...... arr1(3, 0) = 4: arr1(3, 1) = 5 arr1(4, 0) = 5: arr1(4, 1) = 6 '直到下一行,有变化: arr1(5, 0) = 6: arr1(5, 1) = 8 '源表第6列,复制到目标表第8列 arr1(6, 0) = 7: arr1(6, 1) = 9 ' 6个参数定义完毕,以下调用公共模块,开始复制/写数据: rlt = cpSht2Sht(参数1, 参数2, 参数3, 参数4, 参数5, arr1) Debug.Print (rlt) ' 参照以上示例,可以把其它几个表间复制的动作都写成类似CopySht()这样的子程序, ' 而公共模块cpSht2Sht,可反复调用. End Sub ' 参照以上示例,假定需要复制 [表四甲甲供材料表] -->[主材 (甲供)],可以这样做: Sub CopySht2() Dim rlt As Boolean Dim 参数1 As Integer, 参数2 As Integer, 参数3 As Integer Dim 参数4 As String, 参数5 As String '调用cpSht2Sht示例 '数据源的[表四甲甲供材料表]的第9列非零时,需要复制,所以参数1 = 9 参数1 = 9 '从数据源的[表四甲甲供材料表]的第8行开始复制,所以参数2=8 参数2 = 8 '从目标表的[主材 (甲供)]的第7行开始输出,所以参数3=8 参数3 = 7 '源表名称:"表四甲甲供材料表",所以参数4="表四甲甲供材料表" 参数4 = "表四甲甲供材料表" '目标表名称:"主材 (甲供)",所以参数5="主材 (甲供)" 参数5 = "主材 (甲供)" '接下来,需要定义源表与目标表之间的列对应关系(参数6,是一个数组) '由于有6列数列需要复制,故定义数组为6行,2列: Dim arr1(5, 1) As Integer arr1(0, 0) = 1: arr1(0, 1) = 2 '源表第1列,复制到目标表第2列 arr1(1, 0) = 2: arr1(1, 1) = 3 '源表第2列,复制到目标表第3列 arr1(2, 0) = 3: arr1(2, 1) = 4 '...... arr1(3, 0) = 4: arr1(3, 1) = 5 arr1(4, 0) = 5: arr1(4, 1) = 6 '直到下一行,有变化: arr1(5, 0) = 6: arr1(5, 1) = 8 '源表第6列,复制到目标表第8列 ' 6个参数定义完毕,以下调用公共模块,开始复制/写数据: rlt = cpSht2Sht(参数1, 参数2, 参数3, 参数4, 参数5, arr1) Debug.Print (rlt) End Sub