Question

我现在正在使用一个可以正常使用的脚本（下面），虽然需要大量的手动工作才能使用它，效果不是我需要的100％。

我希望此脚本始终复制固定文件的内容（MIS_rapport.csv）并将其粘贴到其他工作簿的活动工作表中，名为Based.xls

任何帮助？

提前致谢！

Private Declare Function SetCurrentDirectoryA Lib _
 "kernel32" (ByVal lpPathName As String) As Long



Sub ChDirNet(szPath As String)
     SetCurrentDirectoryA szPath
End Sub

Sub Combine_Workbooks_Select_Files()
     Dim MyPath As String
     Dim SourceRcount As Long, Fnum As Long
     Dim mybook As Workbook, BaseWks As Worksheet
     Dim sourceRange As Range, destrange As Range
     Dim rnum As Long, CalcMode As Long
     Dim SaveDriveDir As String
     Dim FName As Variant

    With Application
         CalcMode = .Calculation
         .Calculation = xlCalculationManual
         .ScreenUpdating = False
         .EnableEvents = False
     End With

    SaveDriveDir = CurDir
     ChDirNet "C:\"

    FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
                                         MultiSelect:=True)
     If IsArray(FName) Then
         Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
         rnum = 1
         For Fnum = LBound(FName) To UBound(FName)
             Set mybook = Nothing
             On Error Resume Next
             Set mybook = Workbooks.Open(FName(Fnum))
             On Error GoTo 0
             If Not mybook Is Nothing Then
                 On Error Resume Next
                 With mybook.Worksheets(1)
                     Set sourceRange = .Range("A1:W300")
                 End With
                 If Err.Number > 0 Then
                     Err.Clear
                     Set sourceRange = Nothing
                 Else
         If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                         Set sourceRange = Nothing
                     End If
                 End If
                 On Error GoTo 0

                If Not sourceRange Is Nothing Then

                    SourceRcount = sourceRange.Rows.Count

                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                         MsgBox "Not enough rows in the sheet. "
                         BaseWks.Columns.AutoFit
                         mybook.Close savechanges:=False
                         GoTo ExitTheSub
                     Else
                         Set destrange = BaseWks.Range("A" & rnum)
                         With sourceRange
                             Set destrange = destrange. _
                                             Resize(.Rows.Count, .Columns.Count)
                         End With
                         destrange.Value = sourceRange.Value

                        rnum = rnum + SourceRcount
                     End If
                 End If
                 mybook.Close savechanges:=False
             End If
         Next Fnum
         BaseWks.Columns.AutoFit
     End If
ExitTheSub:
    With Application
         .ScreenUpdating = True
         .EnableEvents = True
         .Calculation = CalcMode
     End With
     ChDirNet SaveDriveDir
 End Sub

Answer 1

打开单独的文件：

ChDir "[Path here]"                          'get into the right folder here
Workbooks.Open Filename:= "[Path here]"      'include the filename in this path

'copy data into workbook using: Sheets("workbookname").Range("A2") or_
'select sheets and use ActiveSheet.

ActiveWindow.Close                          'closes out the file

在This其他帖子上阅读我的完整答案以获取更多背景信息

调整脚本 - 从外部源复制数据

1 个答案: