excel合并工作簿VBA

最新推荐文章于 2024-04-30 16:58:01 发布

zhulinniao

最新推荐文章于 2024-04-30 16:58:01 发布

阅读量1k

点赞数

分类专栏：工程trick 文章标签：工作 vba excel c

【博客公式均自己亲自推导和撰写，请转载请注明出处，文章如有侵权、未引用出处等请及时联系whaozl@126.com 或留言评论】【很多已会但是会忘,写纯粹是为了多总结多向前看看和向后看看】

本文链接：https://blog.csdn.net/zhulinniao/article/details/7779611

版权

工程trick 专栏收录该内容

39 篇文章 0 订阅

订阅专栏

主要内容如下：

Sub 合并工作簿()

Dim p As Integer
Dim s As Integer
Dim i As Integer
Dim hao As String
Dim fd As FileDialog
Dim strPath As String

Application.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 If

Set fd = Nothing

na = Dir(strPath & "\*.xls") '需要合并的所有工作表都要事先保存在F:\数据\20120705\文件夹下
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 Then
        For i = 1 To 50
            template.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  '已发行单位
        Next
    Else: MsgBox "格式已经变更，更改一下"
    End If
    template.UsedRange.Copy '复制数据
    'ActiveCell.CurrentRegion.Select  '选择区域(不知道多少行)
        
    newshe.Activate
        
    'Cells(s, 1) = wb.Name '写入数据所属的工作簿名字
    's = s + 1
    
    s = newshe.UsedRange.Rows.Count

    s = s + 1
    newshe.Cells(s, 1).Select
    ActiveSheet.Paste '执行粘贴
    wb.Close '关闭工作簿
    na = Dir() '取下一个工作簿
Loop
Application.DisplayAlerts = True
newshe.Activate

'以下下进行格式调整
Columns("A:A").Select
Application.CutCopyMode = False
Selection.NumberFormatLocal = "yyyy-mm-dd"
Columns("B:B").Select
Selection.NumberFormatLocal = "00000"


Range("A1").Select
newshe.UsedRange.Select '全选

Call 匹配
ThisWorkbook.Worksheets(3).Activate
End Sub