既存のブックのシートにデータを追加し、新しいブックを作成しない方法

Question

次のVBAコードを変更して、ワークブックに既に存在するデータの最後にデータを追加する必要があります"メイン" という名前と "まとめ" という名前のワークシート：

Sub MergeAllWorkbooks() 
Dim MyPath As String, FilesInPath As String 
Dim MyFiles() 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 

' Change this to the path\folder location of your files. 
MyPath = "C:\test\" 

' Add a slash at the end of the path if needed. 
If Right(MyPath, 1) <> "\" Then 
    MyPath = MyPath & "\" 
End If 

' If there are no Excel files in the folder, exit. 
FilesInPath = Dir(MyPath & "*.xl*") 
If FilesInPath = "" Then 
    MsgBox "No files found" 
    Exit Sub 
End If 

' Fill the myFiles array with the list of Excel files 
' in the search folder. 
FNum = 0 
Do While FilesInPath <> "" 
    FNum = FNum + 1 
    ReDim Preserve MyFiles(1 To FNum) 
    MyFiles(FNum) = FilesInPath 
    FilesInPath = Dir() 
Loop 
FNum = FNum - 1 

' Set various application properties. 
With Application 
    CalcMode = .Calculation 
    .Calculation = xlCalculationManual 
    .ScreenUpdating = False 
    .EnableEvents = False 
End With 

' Add a new workbook with one sheet. 
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) 
rnum = 1 

' Loop through all files in the myFiles array. 
If FNum > 0 Then 
    For FNum = LBound(MyFiles) To UBound(MyFiles) 
     Set mybook = Nothing 
     On Error Resume Next 
     Set mybook = Workbooks.Open(MyPath & MyFiles(FNum)) 
     On Error GoTo 0 

     If Not mybook Is Nothing Then 
      On Error Resume Next 

      ' Change this range to fit your own needs. 
      With mybook.Worksheets(1) 
       Set sourceRange = .Range("A2:T" & CStr(mybook.Worksheets(1).Range("A2").CurrentRegion.Rows.Count)) 
      End With 

      If Err.Number > 0 Then 
       Err.Clear 
       Set sourceRange = Nothing 
      Else 
       ' If source range uses all columns then 
       ' skip this file. 
       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 "There are not enough rows in the target worksheet." 
        BaseWks.Columns.AutoFit 
        mybook.Close savechanges:=False 
        GoTo ExitTheSub 
       Else 

        ' Copy the file name in column A. 
        With sourceRange 
         BaseWks.Cells(rnum, "A"). _ 
           Resize(.Rows.Count).Value = MyFiles(FNum) 
        End With 

        ' Set the destination range. 
        Set destrange = BaseWks.Range("B" & rnum) 

        ' Copy the values from the source range 
        ' to the destination range. 
        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: 
' Restore the application properties. 
With Application 
    .ScreenUpdating = True 
    .EnableEvents = True 
    .Calculation = CalcMode 
End With 
End Sub 

私はこのコードを好きではないあなたに

Answer 1

ありがとうございます。私がオブジェクトが、私はエラー処理の使用についての最も不幸な思いがたくさんあります：

• 機能を処理エラーが何かがうまくいかないとき、あなたのルーチンが正常に失敗することを可能にすることがあります。あなたがエラーを無視し、起こらなかったかのように続けていくことは許されません。

• エラー処理でブックのいずれかの問題を処理できませんでした。私は調査していませんが、問題は単一セルの長さか、転送されるデータの合計長さがdestrange.Value = sourceRange.Valueであると思われます。

しかし、私はそれを制限するために単一の変更を行う方法を尋ねます。

ワークシート「要約」でワークブック「メイン」を作成し、そこにマクロを組み込むのが最も簡単な方法を提案します。

Dim文の下に新しいステートメントを追加：上記のコードの

Dim rnum As Long, CalcMode As Long 

    '### Start of new code  
    If Workbooks.Count > 1 Then 
    ' It is easy to get into a muddle if there are multiple workbooks 
    ' open at the start of a macro like this. Avoid the problem until 
    ' you understand it. 
    Call MsgBox("Please close all other workbooks", vbOKOnly) 
    Exit Sub 
    End If 

    Set BaseWks = ActiveWorkBook.Worksheets("Summary") 
    With BaseWks 
    rnum = .Cells(Rows.Count, "A").End(xlUp).Row + 1 
    End With 
'### End of new code 

' Change this to the path\folder location of your files. 

最初のブロックには他のブックが開い存在しない保証します。

第2ブロック（1）は、ワークシート「概要」にBaseWksを設定し、（2）は「サマリー」の最初の未使用行にrnumを設定します。 End(xlUp)は、Ctrl + Upをクリックした場合のVBAに相当します。だから、私は列Aの一番下に行って、値をつけて行を打ち、1行を下げるまで行った。私はワークブック「メイン」は他のブックと同じフォルダになることを前提とし

Do While FilesInPath <> "" 

    If FilesInPath <> ActiveWorkbook.Name Then 
     FNum = FNum + 1 
     ReDim Preserve MyFiles(1 To FNum) 
     MyFiles(FNum) = FilesInPath 
    End If 
    FilesInPath = Dir() 

    Loop 

：

はしてファイル名を見つけループを交換してください。この変更により、「Main」がソースとして使用されないことが保証されます。

破棄これらの文：

Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) 
rnum = 1 

私はすでに、私は必要な値にBaseWksとrnumを設定しているため。あなたは自動的に更新ワークブック「メイン」を保存したい場合は

、ExitTheSub:の上に次のステートメントを追加します。

ActiveWorkbook.Save