主要内容如下：
Sub 合并工作簿()Dim p As IntegerDim s As IntegerDim i As IntegerDim hao As StringDim fd As FileDialogDim strPath As StringApplication.DisplayAlerts = False '关闭提示窗口Set newshe = ThisWorkbook.Worksheets(1) '本工作簿的第一个工作表Set template = ThisWorkbook.Worksheets(2) '临时工作表newshe.Rows("2:1048576").Delete '删除工作簿的第一个工作表的所有数据(除了第一行标题外)'右键按钮 选择控件格式 点击 属性 选择 对象位置和大小 选择不随单元格变化 点击确定即可s = 0'使用FileDialog对象选择文件夹Set fd = Application.FileDialog(msoFileDialogFolderPicker)'显示文件夹对话框fd.Title = "港股合并,请选择数据所在文件夹,然后点击确定"fd.InitialFileName = ThisWorkbook.Path '本工作当前路径If fd.Show = -1 Then '用户选择了文件夹strPath = fd.SelectedItems(1)Else: strPath = ""'MsgBox "您没有选择数据所在文件夹路径"Exit Sub '退出程序下面执行End IfSet fd = Nothingna = Dir(strPath & "\*.xls") '需要合并的所有工作表都要事先保存在F:\数据\0705\文件夹下Do While na <> ""template.Rows("1:10").Delete '将第1行至第10行删除Set wb = Application.Workbooks.Open(strPath & "\" & na)If InStr(wb.Worksheets(1).Cells(10, 1), "日期") > 0 And _InStr(wb.Worksheets(1).Cells(8, 1), "代號") > 0 And _InStr(wb.Worksheets(1).Cells(13, 1), "資產淨值(以交易貨幣計算)") > 0 And _InStr(wb.Worksheets(1).Cells(20, 1), "香港單位") > 0 And _InStr(wb.Worksheets(1).Cells(17, 1), "香港單位") > 0 ThenFor i = 1 To 50template.Cells(i, 1) = wb.Worksheets(1).Cells(10, (i * 3)).Value '第C列表示第3列template.Cells(i, 2) = wb.Worksheets(1).Cells(8, (i * 3)).Value '代码template.Cells(i, 3) = wb.Worksheets(1).Cells(13, i * 3).Value '单位净值template.Cells(i, 4) = wb.Worksheets(1).Cells(20, i * 3).Value '资产净额总值template.Cells(i, 5) = wb.Worksheets(1).Cells(17, i * 3).Value '已发行单位NextElse: MsgBox "格式已经变更，更改一下"End Iftemplate.UsedRange.Copy '复制数据'ActiveCell.CurrentRegion.Select '选择区域(不知道多少行)newshe.Activate'Cells(s, 1) = wb.Name '写入数据所属的工作簿名字's = s + 1s = newshe.UsedRange.Rows.Counts = s + 1newshe.Cells(s, 1).SelectActiveSheet.Paste '执行粘贴wb.Close '关闭工作簿na = Dir() '取下一个工作簿LoopApplication.DisplayAlerts = Truenewshe.Activate'以下下进行格式调整Columns("A:A").SelectApplication.CutCopyMode = FalseSelection.NumberFormatLocal = "yyyy-mm-dd"Columns("B:B").SelectSelection.NumberFormatLocal = "00000"Range("A1").Selectnewshe.UsedRange.Select '全选Call 匹配ThisWorkbook.Worksheets(3).ActivateEnd Sub
