★造个新词——定位模版★ 设置定位模版配合记录数据

54647792

为什么发不了图？

54647792

C:\Documents and Settings\Administrator\桌面

54647792

我有权限发图片啊？怎么就上不去呢？

phweiliang

LangQueS版主您好！                       我们公司最近启用了一个新的系统，领导需要我们从很多报表中把数据汇总起来，手工录入的话不太现实，深感能力不够。当在Excel home技术论坛看到您发表的《[size=1em][源码全部公开][size=1em] [size=1em]★造个新词——定位模版★ 设置定位模版配合记录数据》心中大喜，当即下载学习，只是我们公司的报表与您的模板有点差异，我试了几次没有成功， 附件：文件夹a内有很多份报表，需要将其中的数据汇总起来，LangQueS版主是定位模板的开山鼻祖，所以小弟想劳烦您帮我看看，小弟将不胜感激 。

幻砾

谢谢楼主 下载学习

panjinqy

收藏学习一下。

LangQueS

phweiliang 发表于 2012-5-16 08:01
LangQueS版主您好！                       我们公司最近启用了一个新的系统，领导需要我们从很多报表中把数 ...

跳纤数据汇总.rar (70.71 KB, 下载次数: 144)

2012-5-29 22:08 上传

点击文件名下载附件

LangQueS

或者这样：

1. Sub 合并格式报表()
   
2. '循环当前文件夹中所有工作簿的所有工作表并按定位模版抄录到“合并格式报表.xls”的数据库表
   
3. On Error Resume Next    '忽略错误继续执行VBA代码,避免出现错误消息
   
4. Application.Calculation = xlCalculationManual    '手动重算
   
5.    
   
6. KK = ThisWorkbook.Name         '当前工作簿名称
   
7.    
   
8.     ff = Dir(ThisWorkbook.Path & "\*.xls")    '搜索当前文件夹
   
9.     Do While ff > " "    '只要指定的条件为 True，则会重复执行
   
10.         If ff <> ThisWorkbook.Name Then    '如果不是当前工作簿
    
11.             Set wb = Workbooks.Open(ThisWorkbook.Path & "" & ff)    '打开工作簿
    
12.             For i = 1 To wb.Sheets.Count    '循环工作表
    
13.                 With wb.Sheets(i)
    
14. '===============================================================================
    
15. If Workbooks(KK).Sheets("定位模版").Range("a2") < 1 Then Exit Sub    '否则就退出程序
    
16. 
    
17. a = Workbooks(KK).Sheets("定位模版").Range("A2").Value    '使用在A2单元返回的数据行数
    
18. b = Workbooks(KK).Sheets("数据库").Columns(1).Find("*", , xlValues, , , 2).Row    '数据库第1列最后可见非空单元行号
    
19. 
    
20. For Each r In Workbooks(KK).Sheets("定位模版").UsedRange    '数组方式——将定位模版工作表所有单元纳入数组
    
21. 
    
22. '酸橙色单元为1对多行
    
23.     If r.Interior.ColorIndex = 43 Then    '如果单元颜色为酸橙色则
    
24.         cc = r.Address    '单元地址
    
25.         c = .Range(cc)    '返回报表相应单元内容
    
26.         d = Workbooks(KK).Sheets("数据库").Range("1:1").Find(What:=r, After:=Workbooks(KK).Sheets("数据库").Range("A1"), LookAt:=xlWhole, SearchOrder:=xlByRows).Column    '匹配查找数据库表首行返回列号
    
27.         If d > 0 Then
    
28.             e = Split(Cells(1, d).Address, "$")(1)    '转为列标
    
29.             Workbooks(KK).Sheets("数据库").Range(e & b + 1 & ":" & e & b + a).Value = c    '记录到数据库多行
    
30.         End If
    
31.     End If
    
32. 
    
33. '茶色单元为分别记录多行
    
34.     If r.Interior.ColorIndex = 40 Then    '如果单元颜色为茶色则
    
35.         For f = 1 To a    '循环行
    
36.         cc = r.Address    '单元地址
    
37.             c = .Range(cc).Offset(f, 0).Value    '返回报表相应单元内容
    
38.             d = Workbooks(KK).Sheets("数据库").Range("1:1").Find(What:=r, After:=Workbooks(KK).Sheets("数据库").Range("A1"), LookAt:=xlWhole, SearchOrder:=xlByRows).Column    '匹配查找数据库表首行返回列号
    
39.             If d > 0 Then
    
40.                 e = Split(Cells(1, d).Address, "$")(1)    '转为列标
    
41.                 Workbooks(KK).Sheets("数据库").Range(e & b + f) = c     '记录一个单元
    
42.             End If
    
43.         Next
    
44.     End If
    
45. 
    
46. '向数据库表A列写入行号
    
47.     Workbooks(KK).Sheets("数据库").Range("A" & b + 1 & ":A" & b + a) = "=row()"    '写入行号公式
    
48. 
    
49. '向数据库表指定列写入表格文件名称和工作表名称
    
50.     Workbooks(KK).Sheets("数据库").Range("ba" & b + 1 & ":ba" & b + a) = ff    '将工作簿名称写入AB列
    
51.     Workbooks(KK).Sheets("数据库").Range("bb" & b + 1 & ":bb" & b + a) = Sheets(i).Name    '将工作表名称写入BB列
    
52. 
    
53. Next
    
54. '==============================================================================
    
55.                 End With
    
56.             Next
    
57.             wb.Close 1    '关闭 Open 语句所打开的输入/输出 (I/O) 文件。
    
58.         End If
    
59.         ff = Dir
    
60.     Loop
    
61. 
    
62. Application.Calculation = xlCalculationAutomatic    '自动重算
    
63. On Error GoTo 0    '恢复正常的错误提示
    
64. End Sub

复制代码

剑波

感谢分享，很有用

phweiliang

太感谢您了！{:soso_e163:}