|
楼主 |
发表于 2018-5-5 08:48
|
显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
14885553.rar
(248.73 KB, 下载次数: 1113)
- Rem 清空汇总表原有数据,保留标题
- Set SH1 = Sheets("表一")
- Set SH2 = Sheets("表二")
- SH1.Range("C5:I65536").ClearContents
- SH2.Range("D5:J65536").ClearContents
-
- Rem 获取文件清单
- FileArr = FileAllArr(ThisWorkbook.Path, "*.xls?", ThisWorkbook.Name, True, False)
- If FileArr(0) <> "" Then '//如果文件清单 不是空白的
- ICOUNT = UBound(FileArr) + 1
- Rem 遍历每个分表文件
- For I = 0 To ICOUNT - 1
- StrNameFile = GetPathFromFileName(FileArr(I), False)
- Rem 提示信息,在状态栏显示
- Application.StatusBar = "文件总数:" & ICOUNT & " 当前是第:" & I + 1 & " 当前提取的文件是:" & StrNameFile
- DoEvents
-
- Rem 确认公司名,假设表一中有的,表二也有
- StrNameGS = ""
- FROW = 0
- For IROW = 6 To SH1.Range("A65536").End(3).Row
- If InStr(SH1.Cells(IROW, 1).Value, StrNameFile) > 0 Then
- StrNameGS = SH1.Cells(IROW, 1).Value
- FROW = IROW
- Exit For
- End If
- Next
- If FROW > 0 Then
- Set WB = Workbooks.Open(FileArr(I))
- Rem 表一
- Set SHN = WB.Worksheets("" & SH1.Name)
- Rem 找到分表中公司所在行
- Set C = SHN.Range("A:A").Find(StrNameGS, , LOOKAT:=xlWhole)
- If Not C Is Nothing Then
- Rem 将此行数据复制到汇总表对应行中
- For ICOL = 3 To 9
- SH1.Cells(FROW, ICOL).Value = SHN.Cells(C.Row, ICOL).Value
- Next
- End If
-
- Rem 表 二
- Set C = SH2.Range("A:A").Find(StrNameGS, , LOOKAT:=xlWhole)
- If Not C Is Nothing Then
- FROW = C.Row
- End If
- Set SHN = WB.Worksheets("" & SH2.Name)
- Set C = SHN.Range("A:A").Find(StrNameGS, , LOOKAT:=xlWhole)
- If Not C Is Nothing Then
- For ICOL = 4 To 10
- SH2.Cells(FROW, ICOL).Value = SHN.Cells(C.Row, ICOL).Value
- SH2.Cells(FROW + 1, ICOL).Value = SHN.Cells(C.Row + 1, ICOL).Value
- Next
- End If
-
- WB.Close False
- End If
- Next I
- End If
复制代码 |
评分
-
2
查看全部评分
-
|