VBA合并问题。选择合并文件数量在进行合并

ztsss161511

本人小白，如标题，VBA想要达到效果：
     点击"导入1"文件”Sheet1”中的按钮后，在文件夹内可选择合并文件数量，然后在进行合并，并把结果放在"导入1"文件”Sheet2”中。
因这个文件夹里面可能还有其他数据文件，且有时不想把EXCEL文件全部合并（根据需求可能合并两个文件或几个文件），所以可选择数量很重要，看大佬们可以实现吗？

饮冰e士

WPS好像自带这个功能，只是需要手动操作几步。

f8b1987

WPS支持就行了，会有有合并功能

短腿小居居。

仅供参考，Excel可用，WPS没有试过

1. Sub test()
   
2.     Application.ScreenUpdating = False
   
3.     Sheets("SHEET2").Range("A1").CurrentRegion.ClearContents
   
4.     Dim ARR, BRR
   
5.     ReDim BRR(1 To 1048576, 1 To 4)
   
6.     J = 1
   
7.     BRR(1, 1) = "序号"
   
8.     BRR(1, 2) = "项目"
   
9.     BRR(1, 3) = "时间"
   
10.     BRR(1, 4) = "累计量"
    
11.     ChDir ThisWorkbook.Path
    
12.     A = Application.GetOpenFilename("Excel文件,*.xls*", MultiSelect:=True)
    
13.     COST = Timer
    
14.     If IsArray(A) Then
    
15.         For I = LBound(A) To UBound(A)
    
16.             If A(I) <> ThisWorkbook.FullName Then
    
17.                 Application.Workbooks.Open (A(I))
    
18.                 ARR = ActiveWorkbook.Sheets(1).Range("A1").CurrentRegion
    
19.                 ActiveWorkbook.Close False
    
20.                 For II = LBound(ARR) + 1 To UBound(ARR)
    
21.                     J = J + 1
    
22.                     BRR(J, 1) = ARR(II, 1)
    
23.                     BRR(J, 2) = ARR(II, 2)
    
24.                     BRR(J, 3) = ARR(II, 3)
    
25.                     BRR(J, 4) = ARR(II, 4)
    
26.                 Next
    
27.             End If
    
28.         Next
    
29.         Sheets("SHEET2").Range("A1").Resize(J, 4) = BRR
    
30.         Sheets("SHEET2").Range("C:C").NumberFormat = "YYYY-MM-DD"
    
31.         MsgBox "完成,耗时：" & Format(Timer - COST, "0.00秒")
    
32.     Else
    
33.         MsgBox "NO SELECT"
    
34.     End If
    
35.     Application.ScreenUpdating = True
    
36. End Sub
    
37. 
    

复制代码

zpy2

https://club.excelhome.net/forum.php?mod=viewthread&tid=1662588&mobile=2&_dsign=236fc179

3190496160

Sub 导入多工作簿()
Dim oWb As Object: Set oWb = ThisWorkbook
Dim intFilesCount As Integer
Dim strFilePath As String
Dim rs
Dim rn As Range
Application.ScreenUpdating = False    '屏幕闪烁关闭
Set sh = ThisWorkbook.Worksheets("sheet2")
sh.UsedRange = Empty
Dim oFd As Object
Set oFd = Application.FileDialog(msoFileDialogFilePicker)
With oFd
    .AllowMultiSelect = True
    .Filters.Add "Excel文档", "*.xls*; *.xls*; *.xls*", 1
    .FilterIndex = 1
    .InitialFileName = oWb.Path
    .InitialView = msoFileDialogViewDetails
    If .Show = -1 Then
        intFilesCount = .SelectedItems.Count
        For i = 1 To intFilesCount
            strFilePath = .SelectedItems(i)
            Set Wb = Workbooks.Open(strFilePath)
            If i = 1 Then
                Set rn = Wb.Worksheets(1).[a1].CurrentRegion
                rn.Copy sh.Cells(1, 1)
            Else
               Set rn = Wb.Worksheets(1).[a1].CurrentRegion.Offset(1)
               rs = sh.[a65536].End(xlUp).Row + 1
               rn.Copy sh.Cells(rs, 1)
            End If
            Wb.Close False
            Set rn = Nothing
        Next i
    Else
        Exit Sub
    End If
End With
Application.ScreenUpdating = True    '
MsgBox "ok"
End Sub

3190496160

3190496160

合并.rar (1.72 MB, 下载次数: 6)

2023-5-29 16:03 上传

点击文件名下载附件