合并同类报表工具分享

考试加油站

shaowu459 发表于 2011-2-27 14:45
已更新2003版，在1楼。合并时会提示输入一个密码，示例文件中请入123，自己合并自己的表格时可选择取消即 ...

1楼不能用，提示：
丢失了 Visual Basic 项目。
丢失了 ActiveX 控件。

shaowu459

考试加油站 发表于 2012-5-19 21:03
1楼不能用，提示：
丢失了 Visual Basic 项目。
丢失了 ActiveX 控件。

不好意思，我的电脑是英文版的，可能会造成汉语系统打开时丢失项目问题。这个。。我也不知道咋解决，哎

考试加油站

shaowu459 发表于 2012-5-19 21:06
不好意思，我的电脑是英文版的，可能会造成汉语系统打开时丢失项目问题。这个。。我也不知道咋解决，哎

那您能将03版代码直接贴上来吗

shaowu459

模块中的代码：

1. Sub actionModule()
   
2.     Dim i, j As Integer
   
3.     Dim num As Integer
   
4.     Dim extention As String
   
5.     Dim Sh As Worksheet, myName$, n%
   
6.     Dim myDelimiter As String
   
7.     Dim Password As String
   
8. 
   
9.     Password = InputBox("要合并的工作表是否有保护？若无请点击取消，若有请输入密码。", "密码保护确认")
   
10. 
    
11.     Application.DisplayAlerts = False
    
12.     Application.ScreenUpdating = False
    
13. 
    
14.     For Each Sh In Worksheets
    
15.         If Sh.Name <> ActiveSheet.Name Then             '可修改参数
    
16.             Sh.Delete
    
17.         End If
    
18.     Next
    
19. 
    
20.     For i = 1 To shsSelect.ListView2.ListItems.Count
    
21.         If shsSelect.ListView2.ListItems(i).Checked = True Then
    
22.             num = num + 1
    
23.         End If
    
24.     Next i
    
25. 
    
26.     If num = 0 Then
    
27.         MsgBox "请注意，您没有选定任何工作表合并！请重新选择需要合并的工作表！"
    
28.         Exit Sub
    
29.     End If
    
30. 
    
31. 
    
32.     n = 1
    
33.     myName = Dir(ThisWorkbook.Path & "\*.xls*")
    
34.     Range("a2:b65536").ClearContents
    
35.     Range("a2:b65536").Hyperlinks.Delete
    
36. 
    
37. PP:
    
38.     myDelimiter = InputBox("请输入文件名的分割标识符，默认设置将以被合并Workbook的文件名为Worksheet名称。若输入被合并文件的统一后缀（或文件名中均有的相同文本），如“.20101231”，则被合并Workbook文件名在“.20101231”以前部分将作为合并后的Worksheet名称。", "请输入文件名分隔符", ".xl")
    
39. 
    
40.     If myDelimiter = "" Then
    
41.         MsgBox "分隔符不能为空！请重新输入分隔符！"
    
42.         GoTo PP
    
43.     End If
    
44. 
    
45.     Do While myName <> ""
    
46. 
    
47.         If myName <> ThisWorkbook.Name Then
    
48. 
    
49.             If InStr(myName, myDelimiter) = 0 Then
    
50.                 MsgBox "输入的分隔符有错误，文件名中并不包含此字符串，请重新输入分隔符。"
    
51.                 GoTo PP
    
52.             End If
    
53. 
    
54.             Workbooks.Open ThisWorkbook.Path & "" & myName
    
55. 
    
56.             If Password <> "" Then
    
57.                 For j = 1 To ActiveWorkbook.Sheets.Count
    
58.                     ActiveWorkbook.Sheets(j).Unprotect Password
    
59.                 Next j
    
60.             End If
    
61. 
    
62.             Application.StatusBar = "正在处理工作薄" & ActiveWorkbook.Name & "，请稍候……"
    
63. 
    
64.             For i = 1 To shsSelect.ListView2.ListItems.Count
    
65. 
    
66.                 If shsSelect.ListView2.ListItems(i).Checked = True Then
    
67.                     ActiveWorkbook.Sheets(shsSelect.ListView2.ListItems(i).Text).Activate
    
68. 
    
69.                     ActiveWorkbook.Sheets(shsSelect.ListView2.ListItems(i).Text).Range("D217:J245").Select
    
70.                     Selection.Copy
    
71.                     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    
72.                                                                                   :=False, Transpose:=False
    
73. 
    
74. 
    
75.                     ActiveWindow.View = xlNormalView
    
76.                     ActiveWindow.Zoom = 85
    
77.                     ActiveWorkbook.Sheets(shsSelect.ListView2.ListItems(i).Text).Copy After:=ThisWorkbook.Sheets(n)
    
78.                     n = n + 1
    
79. 
    
80.                     If num > 1 Then
    
81.                         extention = "-" & shsSelect.ListView2.ListItems(i).Text
    
82.                     Else
    
83.                         extention = ""
    
84.                     End If
    
85. 
    
86. 
    
87. 
    
88. 
    
89.                     ThisWorkbook.Sheets(n).Name = VBA.Left(myName, InStr(myName, myDelimiter) - 1) & extention
    
90.                     ThisWorkbook.Worksheets("首页").Range("a" & n) = n - 1
    
91.                     ThisWorkbook.Worksheets("首页").Hyperlinks.Add ThisWorkbook.Worksheets("首页").Range("b" & n), Address:="", SubAddress:="'" & ThisWorkbook.Sheets(n).Name & "'!A1", ScreenTip:=ThisWorkbook.Sheets(n).Name, TextToDisplay:=ThisWorkbook.Sheets(n).Name
    
92.                     ActiveSheet.Hyperlinks.Add ActiveSheet.Range("p1"), Address:="", SubAddress:=Sheets(1).Name & "!A1", ScreenTip:="返回首页", TextToDisplay:="返回"
    
93. 
    
94.                     Workbooks(myName).Activate
    
95.                 End If
    
96.             Next i
    
97. 
    
98.             If Password <> "" Then
    
99.                 For j = 1 To ActiveWorkbook.Sheets.Count
    
100.                     ActiveWorkbook.Sheets(j).Protect Password
     
101.                 Next j
     
102.             End If
     
103. 
     
104.             Workbooks(myName).Close
     
105.         End If
     
106.         myName = Dir
     
107.     Loop
     
108. 
     
109.     Application.StatusBar = False
     
110. 
     
111.     ThisWorkbook.Sheets(1).Activate
     
112. 
     
113.     Application.ScreenUpdating = True
     
114.     Application.DisplayAlerts = True
     
115. 
     
116.     Application.Calculation = xlCalculationAutomatic
     
117. End Sub
     

复制代码

按钮的代码：

1. 
   
2. Private Sub CommandButton1_Click()
   
3. 
   
4. Application.Calculation = xlCalculationManual
   
5. If ThisWorkbook.Worksheets.Count > 1 Then
   
6.     If MsgBox("重新导入报表将删除原来报表，继续吗？        ", 52, "警告") = 7 Then
   
7.         Exit Sub
   
8.     Else
   
9.         shsSelect.Show
   
10.     End If
    
11. Else
    
12.         shsSelect.Show
    
13. End If
    
14. End Sub
    

复制代码

1. Private Sub CommandButton1_Click()
   
2. Dim i, j As Integer
   
3. ListView2.ListItems.Clear
   
4. For i = 1 To ListView1.ListItems.Count
   
5.    If ListView1.ListItems(i).Checked = True Then
   
6.         j = j + 1
   
7.         ListView2.ListItems.Add , , ListView1.ListItems(i).Text
   
8.         ListView2.ListItems(j).Checked = True
   
9.    End If
   
10. Next i
    
11. 
    
12. If j > 0 Then
    
13.     CommandButton5.Enabled = True
    
14.     CommandButton6.Enabled = True
    
15. End If
    
16. End Sub
    
17. 
    
18. Private Sub CommandButton2_Click()
    
19. Dim i As Integer
    
20. For i = ListView2.ListItems.Count To 1 Step -1
    
21.     If ListView2.ListItems(i).Checked = True Then
    
22.         ListView2.ListItems.Remove i
    
23.     End If
    
24. Next i
    
25. 
    
26. If ListView2.ListItems.Count = 0 Then
    
27.     CommandButton5.Enabled = False
    
28.     CommandButton6.Enabled = False
    
29. End If
    
30. 
    
31. End Sub
    
32. 
    
33. Private Sub CommandButton3_Click()
    
34. Dim i As Integer
    
35. For i = 1 To ListView1.ListItems.Count
    
36.     ListView1.ListItems(i).Checked = True
    
37. Next i
    
38. End Sub
    
39. 
    
40. Private Sub CommandButton4_Click()
    
41. Dim i As Integer
    
42. For i = 1 To ListView1.ListItems.Count
    
43.     ListView1.ListItems(i).Checked = False
    
44. Next i
    
45. End Sub
    
46. Private Sub CommandButton6_Click()
    
47. Dim i As Integer
    
48. For i = 1 To ListView2.ListItems.Count
    
49.     ListView2.ListItems(i).Checked = True
    
50. Next i
    
51. End Sub
    
52. 
    
53. Private Sub CommandButton5_Click()
    
54. Dim i As Integer
    
55. For i = 1 To ListView2.ListItems.Count
    
56.     ListView2.ListItems(i).Checked = False
    
57. Next i
    
58. End Sub
    
59. 
    
60. Private Sub CommandButton7_Click()
    
61. shsSelect.Hide
    
62. Call actionModule
    
63. End Sub
    
64. 
    
65. Private Sub UserForm_Initialize()
    
66. 
    
67. Dim myFileName As String
    
68. Dim myName As String
    
69. Dim i As Integer
    
70. Dim wbName As String
    
71. 
    
72. Application.DisplayAlerts = False
    
73. Application.ScreenUpdating = False
    
74. 
    
75. 'VBA.ChDir Application.DefaultFilePath                                           '改变打开的默认路径
    
76. 'myName = ThisWorkbook.Path & ""
    
77. 
    
78. 'SendKeys myName & "{TAB}", True
    
79. 
    
80. PP:
    
81. 
    
82. With Application.FileDialog(msoFileDialogFolderPicker)
    
83.         .InitialFileName = ThisWorkbook.Path & ""
    
84. End With
    
85. myFileName = Application.GetOpenFilename("Excel工作薄 (*.xls*),*.xls*")
    
86. 
    
87. If myFileName = "False" Then
    
88.     MsgBox "没有选择文件！请重新选择一个被合并文件！", vbInformation, "取消"
    
89.     GoTo PP
    
90. Else
    
91.     If myFileName = myName & ThisWorkbook.Name Then
    
92.         MsgBox "您选择的是合并模板，请重新选择一个被合并文件！"
    
93.         GoTo PP
    
94.     Else
    
95.             With ListView2
    
96.             .ColumnHeaders.Clear
    
97.             .ListItems.Clear
    
98.             .ColumnHeaders.Add , , "选定的被合并工作表", ListView2.Width      '添加列标
    
99.             .Gridlines = True
    
100.             End With
     
101. 
     
102.             With ListView1
     
103.             .ColumnHeaders.Clear
     
104.             .ListItems.Clear
     
105.             .ColumnHeaders.Add , , "请选择被合并工作表，可以多选", ListView1.Width             '添加列标
     
106.             .Gridlines = True
     
107.             End With
     
108.         
     
109. 
     
110.    
     
111.         Workbooks.Open Filename:=myFileName
     
112.         wbName = ActiveWorkbook.Name
     
113.         Windows(ActiveWorkbook.Name).Visible = False
     
114.       
     
115.         For i = 1 To Workbooks(wbName).Worksheets.Count                         '获得被合并工作薄各工作表名称
     
116.            ListView1.ListItems.Add , , Workbooks(wbName).Worksheets(i).Name
     
117.         Next i
     
118.         
     
119.         Workbooks(wbName).Close
     
120.     End If
     
121. 
     
122.    
     
123. End If
     
124.     CommandButton5.Enabled = False
     
125.     CommandButton6.Enabled = False
     
126.    
     
127. 
     
128. End Sub
     
129. 
     

复制代码

上面的是useform的代码。这样看着太乱了吧。。。

考试加油站

shaowu459 发表于 2012-5-19 21:11
模块中的代码：按钮的代码：上面的是useform的代码。这样看着太乱了吧。。。

哈，这么多代码啊，不会用，等高人附件传上来再说吧

考试加油站

shaowu459 发表于 2012-5-19 21:11
模块中的代码：按钮的代码：上面的是useform的代码。这样看着太乱了吧。。。

我看一下好多网友和我的一样，显示
丢失了 Visual Basic 项目。
丢失了 ActiveX 控件。
您看一下1楼是不是你上传时就有错误

考试加油站

shaowu459 发表于 2012-5-19 21:11
模块中的代码：按钮的代码：上面的是useform的代码。这样看着太乱了吧。。。

哈，那期待上传一个03中文版的

wzyhome

收藏，谢谢先学习

yangang730105

更新2003版的出现了下列情况：
丢失了 Visual Basic 项目。
丢失了 ActiveX 控件。

shaowu459

yangang730105 发表于 2012-6-16 21:53
更新2003版的出现了下列情况：
丢失了 Visual Basic 项目。
丢失了 ActiveX 控件。

我也没辙了。英文系统做的别人打不开。。。。