返回列表 上一主題 發帖

[發問] VBA 開啟多個檔案 複製貼上

回復 1# character
試試看
  1. Option Explicit
  2. Dim Show_File As Object
  3. Sub 加入檔案()
  4.     Dim I As Integer
  5.     Set Show_File = Application.FileDialog(msoFileDialogOpen)
  6.     With Show_File
  7.          .InitialFileName = "D:\*.xls"  '指定 xls檔
  8.          .AllowMultiSelect = True
  9.          .Show
  10.          If .SelectedItems.Count > 0 Then
  11.             For I = 1 To .SelectedItems.Count
  12.              Cells(I, 2) = .SelectedItems(I)
  13.          Next
  14.          End If
  15.     End With
  16. End Sub
  17. Sub 執行()
  18.     Dim I As Integer, Sh As Worksheet, Rng As Range
  19.     Set Sh = Workbooks("貼上.xlsm").Sheets(1)
  20.     With Show_File
  21.         If .SelectedItems.Count > 0 Then
  22.             For I = 1 To .SelectedItems.Count
  23.                 Set Rng = Sh.Cells(Sh.Rows.Count, "A").End(xlUp).Offset(1)  'A欄最後有資料列的下一列
  24.                 With Workbooks.Open(.SelectedItems(I))
  25.                     .Sheets(1).Range("A1:C6").Copy Rng
  26.                     .Close 0
  27.                 End With
  28.             Next
  29.          End If
  30.     End With
  31.    Sh.Parent.Save   ' 貼上.xlsm  存檔
  32. End Sub
複製代碼

TOP

        靜思自在 : 生氣,就是拿別人的過錯來懲罰自己。
返回列表 上一主題