ループの次の行に別のワークシートのデータを貼り付けます

Question

私はダイアログボックスを開いてワークブックを選択する必要があります。その後、そのブックに置かれたデータをコピーします（同じ名前のシートが常に1枚しかありません）。

vbyesnoのループを使用して、多くのブックの処理を行いたいとします。

これは、Range（ "a14"）の下にデータを貼り付けてから、ループしてからa14に貼り付けたデータの下に貼り付けたいので機能しない部分です。

以下は、別のマクロから呼び出されているマクロです。

Sub prompt() 

    Application.DisplayAlerts = False 
    Dim Target_Workbook As Workbook 
    Dim Source_Workbook As Workbook 
    Dim Target_Path As Range 
    d = MsgBox("Add record?", vbYesNoCancel + vbInformation) 
    If d = vbNo Then 
     ActiveSheet.Range("a13").value = "No data Found" 
     ActiveSheet.Range("a13").Font.Bold = True 
     ThisWorkbook.Save 
    ElseIf d = vbCancel Then 
     Sheets("MPSA").Delete 
     ThisWorkbook.Save 
    ElseIf d = vbYes Then 
     Sheets("MPSA").Range("a14").value = "NAME" 
     Sheets("MPSA").Range("b14").value = "NUMBER" 
     Sheets("MPSA").Range("c14").value = "AGR NUMBER" 
     Sheets("MPSA").Range("d14").value = "ENTITY NAME" 
     Sheets("MPSA").Range("e14").value = "GROUP" 
     Sheets("MPSA").Range("f14").value = "DELIVERABLE" 
     Sheets("MPSA").Range("g14").value = "DELIVERAB" 
     Sheets("MPSA").Range("h14").value = "IS COMPON" 
     Sheets("MPSA").Range("i14").value = "PACKAGE" 
     Sheets("MPSA").Range("j14").value = "ORDERS" 
     Sheets("MPSA").Range("k14").value = "LICNTITY" 
     Sheets("MPSA").Range("l14").value = "QUANTITY" 
     Sheets("MPSA").Range("m14").value = "ORDERANUMBER" 
     Sheets("MPSA").Range("n14").value = "ORDERAM NAME" 
     Sheets("MPSA").Range("o14").value = "PAC NUMBER" 
     Sheets("MPSA").Range("p14").value = "PACKAGAME" 
     Sheets("MPSA").Range("q14").value = "ITTION" 
     Sheets("MPSA").Range("r14").value = "LICENSE TYPE" 
     Sheets("MPSA").Range("s14").value = "ITEM VERSION" 
     Sheets("MPSA").Range("t14").value = "REAGE" 
     Sheets("MPSA").Range("u14").value = "CLIIT" 
     Sheets("MPSA").Range("v14").value = "LICEAME" 
     Sheets("MPSA").Range("w14").value = "ASSATE" 
     Sheets("MPSA").Range("x14").value = "ASSTE" 
     Sheets("MPSA").Range("y14").value = "ENTITTUS" 
     Sheets("MPSA").Range("z14").value = "ASSGORY" 
     Sheets("MPSA").Range("aa14").value = "PURCHAYPE" 
     Sheets("MPSA").Range("ab14").value = "BILLTHOD" 
     Sheets("MPSA").Range("ac14").value = "SALETER" 
     Cells.Columns.AutoFit 
     Target_Path = Application.GetOpenFilename 
     Set Target_Workbook = Workbooks.Open(Target_Path) 
     Set Source_Workbook = ThisWorkbook 

     Target_Data = Target_Workbook.Sheets(1).Range("A1").CurrentRegion.Copy 
     Target_Workbook.Close 
     Source_Workbook.Sheets("MPSA").Range("a14").End(xlDown).Offset(1, 0).PasteSpecial = Target_Data 
     ActiveCell.EntireRow.Delete 
     ThisWorkbook.Save 
     ThisWorkbook.Save 
    End If 
End Sub 

Answer 1

私はあなたの現在のコードがどこかの近くにあなたが達成したいものであると仮定すると、ループを達成するための仕組みを提案するつもりでした。しかし、私は多くの間違いを見つけたので、私はそれをリファクタリングしなければなりません、うまくいけばそれはあなたに一歩を踏み出すでしょう。あなただけの一回の反復のために、このコードは* *動作することを確認してください

Sub prompt() 
    Dim d As VbMsgBoxResult: d = MsgBox("Add record?", vbYesNoCancel + vbInformation) 
    If d = vbNo Then 
     Sheets("MPSA").Range("a13").value = "No data Found" 
     Sheets("MPSA").Range("a13").Font.Bold = True 
     ThisWorkbook.Save 
     Exit Sub 
    End If 
    If d = vbCancel Then 
     Sheets("MPSA").Delete 
     ThisWorkbook.Save 
     Exit Sub 
    End If 

    On Error GoTo Cleanup 
    Application.DisplayAlerts = False: Application.EnableEvents = False: Application.ScreenUpdating = False 

    Sheets("MPSA").Range("a14:ac14").value = Array(_ 
    "NAME", "NUMBER", "AGR NUMBER", "ENTITY NAME", "GROUP", "DELIVERABLE", "DELIVERAB", "IS COMPON", _ 
    "PACKAGE", "ORDERS", "LICNTITY", "QUANTITY", "ORDERANUMBER", "ORDERAM NAME", "PAC NUMBER", "PACKAGAME", _ 
    "ITTION", "LICENSE TYPE", "ITEM VERSION", "REAGE", "CLIIT", "LICEAME", "ASSATE", "ASSTE", _ 
    "ENTITTUS", "ASSGORY", "PURCHAYPE", "BILLTHOD", "SALETER") 

    Sheets("MPSA").Columns.AutoFit 
    Dim Target_Path: Target_Path = Application.GetOpenFilename 
    Do While Target_Path <> False ' <-- loop until user cancels 
     Dim Target_Workbook As Workbook: Set Target_Workbook = Workbooks.Open(Target_Path) 
     Target_Workbook.Sheets(1).Range("A1").CurrentRegion.Copy _ 
      ThisWorkbook.Sheets("MPSA").Range("a1000000").End(xlUp).Offset(1) 
     Target_Workbook.Close False 
     ActiveCell.EntireRow.Delete 
     ThisWorkbook.Save 
     Target_Path = Application.GetOpenFilename 
    Loop 
Cleanup: 
    If Err.Number <> 0 Then MsgBox "Something went wrong: " & vbCrLf & Err.Description 
    Application.DisplayAlerts = True: Application.EnableEvents = True: Application.ScreenUpdating = True 
End Sub