合并多个工作簿+左右两个工作簿进行是否一致匹配

 

1.合并工作簿的宏

代码(合并工作簿) 
 1 Sub 合并工作簿()
 2 
 3 Dim p As Integer
 4 Dim s As Integer
 5 Dim i As Integer
 6 Dim hao As String
 7 Dim fd As FileDialog
 8 Dim strPath As String
 9 
10 Application.DisplayAlerts = False '关闭提示窗口
11 Set newshe = ThisWorkbook.Worksheets(1) '本工作簿的第一个工作表
12 Set template = ThisWorkbook.Worksheets(2) '临时工作表
13 newshe.Rows("2:1048576").Delete '删除工作簿的第一个工作表的所有数据(除了第一行标题外)
14 '右键按钮 选择控件格式 点击 属性 选择 对象位置和大小 选择不随单元格变化 点击确定即可
15 s = 0
16 
17 '使用FileDialog对象选择文件夹
18 Set fd = Application.FileDialog(msoFileDialogFolderPicker)
19 '显示文件夹对话框
20 fd.Title = "港股合并,请选择数据所在文件夹,然后点击确定"
21 fd.InitialFileName = ThisWorkbook.Path '本工作当前路径
22     
23 If fd.Show = -1 Then '用户选择了文件夹
24     strPath = fd.SelectedItems(1)
25 Else: strPath = ""
26     'MsgBox "您没有选择数据所在文件夹路径"
27     Exit Sub '退出程序下面执行
28 End If
29 
30 Set fd = Nothing
31 '关闭屏幕更新，防止闪屏、加快代码运行Application.ScreenUpdating = FalseApplication.ScreenUpdating = FalseApplication.ScreenUpdating = False
32 na = Dir(strPath & "\*.xls") '需要合并的所有工作表都要事先保存在F:\数据\20120705\文件夹下
33 Do While na <> ""
34     template.Rows("1:10").Delete '将第1行至第10行删除
35     Set wb = Application.Workbooks.Open(strPath & "\" & na)
36     
37     
38     
39     If InStr(wb.Worksheets(1).Cells(10, 1), "日期") > 0 And _
40         InStr(wb.Worksheets(1).Cells(8, 1), "代號") > 0 And _
41         InStr(wb.Worksheets(1).Cells(13, 1), "資產淨值(以交易貨幣計算)") > 0 And _
42         InStr(wb.Worksheets(1).Cells(20, 1), "香港單位") > 0 And _
43         InStr(wb.Worksheets(1).Cells(17, 1), "香港單位") > 0 Then
44         For i = 1 To 50
45             template.Cells(i, 1) = wb.Worksheets(1).Cells(10, (i * 3)).Value '第C列表示第3列
46             template.Cells(i, 2) = wb.Worksheets(1).Cells(8, (i * 3)).Value  '代码
47             template.Cells(i, 3) = wb.Worksheets(1).Cells(13, i * 3).Value '单位净值
48             template.Cells(i, 4) = wb.Worksheets(1).Cells(20, i * 3).Value  '资产净额总值
49             template.Cells(i, 5) = wb.Worksheets(1).Cells(17, i * 3).Value  '已发行单位
50         Next
51     Else: MsgBox "格式已经变更，更改一下"
52     End If
53     template.UsedRange.Copy '复制数据
54     'ActiveCell.CurrentRegion.Select  '选择区域(不知道多少行)
55         
56     newshe.Activate
57         
58     'Cells(s, 1) = wb.Name '写入数据所属的工作簿名字
59     's = s + 1
60     
61     s = newshe.UsedRange.Rows.Count
62 
63     s = s + 1
64     newshe.Cells(s, 1).Select
65     ActiveSheet.Paste '执行粘贴
66     wb.Close '关闭工作簿
67     na = Dir() '取下一个工作簿
68 Loop
69 Application.DisplayAlerts = True
70 newshe.Activate
71 
72 '以下下进行格式调整
73 Columns("A:A").Select
74 Application.CutCopyMode = False
75 Selection.NumberFormatLocal = "yyyy-mm-dd"
76 Columns("B:B").Select
77 Selection.NumberFormatLocal = "00000"
78 
79 
80 Range("A1").Select
81 newshe.UsedRange.Select '全选
82 
83 Call 匹配
84 ThisWorkbook.Worksheets(3).Activate
85 End Sub

 

2.匹配的宏

代码(匹配的宏) 
 1 Sub 匹配() '进行匹配
 2     
 3     Dim exceldata1 As Variant '存放sheet1中的数据
 4     Dim exceldata2 As Variant '存放最终结果
 5     
 6     Dim LB1 As Integer, UB1 As Integer
 7     Dim LB2 As Integer, UB2 As Integer
 8     Dim Bin As Boolean '标记 判断是否找到匹配 找到则退出本层循环
 9     Dim CharData As String
10     Dim i As Integer, j As Integer
11 
12     
13     Application.DisplayAlerts = False '关闭提示窗口
14     Set newshe = ThisWorkbook.Worksheets(1) '本工作簿的第一个工作表
15     Set result = ThisWorkbook.Worksheets(3) '存放结果表
16     
17     result.Activate
18     '清除 最终结果中的内容
19     result.Columns("A:A").Select
20     Selection.ClearContents
21     result.Columns("C:C").Select
22     Selection.ClearContents
23     result.Columns("D:D").Select
24     Selection.ClearContents
25     result.Columns("E:E").Select
26     Selection.ClearContents
27     
28     exceldata1 = newshe.UsedRange.Value
29     exceldata2 = result.UsedRange.Value
30     
31     LB1 = LBound(exceldata1, 1) '通过 数组 获取第一维 即行数
32     UB1 = UBound(exceldata1, 1)
33     LB2 = LBound(exceldata2, 1)
34     UB2 = UBound(exceldata2, 1)
35     
36     For i = LB1 To UB1
37         j = LB2
38         Bin = True
39         
40         CharData = Trim(newshe.Cells(i, 2).Value)
41         Do While Bin = True And j <= UB2
42             If Trim(result.Cells(j, 2).Value) = CharData Then
43             result.Cells(j, 1) = newshe.Cells(i, 1).Value
44             result.Cells(j, 3) = newshe.Cells(i, 3).Value
45             result.Cells(j, 4) = newshe.Cells(i, 4).Value
46             result.Cells(j, 5) = newshe.Cells(i, 5).Value
47             Bin = False
48             Exit Do
49             End If
50             j = j + 1
51         Loop
52     Next i
53     
54     result.Activate
55     '以下下进行格式调整
56     Columns("A:A").Select
57     Application.CutCopyMode = False
58     Selection.NumberFormatLocal = "yyyy-mm-dd"
59     Columns("B:B").Select
60     Selection.NumberFormatLocal = "00000"
61     
62     result.UsedRange.Select '全选
63 End Sub

 

posted @ 2012-07-24 13:51  whaozl  阅读(366)  评论(0)  编辑  收藏  举报