none
ブック間での一覧の条件付きコピー&ペーストを繰り返すVBAについて RRS feed

  • 質問

  • Excel2010で作成したブック(以下、「ブックX」)で作成したデータの一覧を、同じくExcel2010で作成した別のブック(以下、「ブックY」)の一覧へ自動的に値貼り付けするVBAを、ブックXに組むことを考えております。

    ※ ブックXのZシートの1行以上分の一覧

    「整理番号」~「データ3」のデータ1行分を複数範囲選択してコピーします。

    ※ ブックYのVシートにある一覧

    ブックYのVシートにある一覧へ値貼り付けするとき、コピー元のZシートの「整理番号」と、コピー先のVシートの「整理番号」を参照し、一致した行へ貼り付けたいのです。
    そして、このコピー&貼り付けを、Zシートの一覧に記載されている整理番号の数(行)だけ、繰り返したいのです。
     (例示では、ブックYのVシートの整理番号「2」、「456」、「789」へ自動的に値貼り付けすることになります。)

    なお、ブックXのコピー元は1行以上あり、且つブックXそのものが2個以上存在します。
     2個以上のブックXは、整理番号や入力されたその他の数値は異なりますが、一覧の構成は同一となっております。

    また、ブックYは1個しか無く、整理番号が「1」から始まって1ずつ増分して下の行へ連続している一覧となっております。

    https://social.msdn.microsoft.com/Forums/ja-JP/aa586420-453d-4f05-acf0-0b23e232ff8d?forum=vbajp での回答を応用し、グーグルで検索したものを組み合わせて下記のとおり作成してみました。

    Sub YシートからVシート貼り付け()

        Application.ScreenUpdating = False
        Dim FN As String
        FN = ThisWorkbook.Worksheets("Zシート").Range("ブックYのファイルの保存場所及びファイル名")

        Dim i As Long '整理番号を「i」に置き換えて、ループを宣言する。
        i = 1
        Do While Cells(i, 1) <> ""
        Cells(i, 1) = Cells(i, 1) + 1
       
        Dim n As String
        n = ThisWorkbook.Worksheets("Zシート").Range("A:D") 'A列(整理番号のある列)からD列(データ3のある列)の範囲を選択する。
      
        Dim T As String
        T = ThisWorkbook.Worksheets("Zシート").Range("ブックYのシート名")

        Dim xlBookA As WorkbooK
        Set xlBookA = ThisWorkbook

        Dim xlBookB As Workbook
        Set xlBookB = Workbooks.Open(FN)

        Dim sheetC As Worksheet
        Set sheetC = xlBookA.Worksheets("Zシート")

        Dim rngC As Range
        Set rngC = sheetC.Range(1, 0)

        Dim sheetD As Worksheet
        Set sheetD = xlBookB.Worksheets(T)

        Dim rngNumbersTitle As Range
        Set rngNumbersTitle = sheetD.Range("A1")  '整理番号のタイトルのセルは、A1セルにある。
       
        Dim rngNubmersEnd As Range
        Set rngNubmersEnd = sheetD.Cells(sheetD.Rows.Count, rngNumbersTitle.Column).End(xlUp)

        Dim rngNumbers As Range
        Set rngNumbers = sheetD.Range(rngNumbersTitle.Offset(1), rngNubmersEnd)

        Dim number As Long
        number = rngC.Cells(i, 1).Value
        Dim rngFound As Range
        Set rngFound = rngNumbers.Find(What:=number, lookat:=xlWhole)

        Dim rngTarget As Range
        If (rngFound Is Nothing) Then
            Set rngTarget = rngNubmersEnd.Offset(1, 0)
        End If

        Call rngC.Copy
        Call rngFound.PasteSpecial(Paste:=xlPasteValues)

     
        If (Not xlBookB.Saved) Then
            Call xlBookB.Save
            Call xlBookB.Close
        End If
       
        i = i + 1
      
        Loop

        Application.ScreenUpdating = True
        MsgBox ("貼り付けは、完了しました。")

    End Sub

    実行はできたものの、ブックYは開いた形跡がなく、またZシートへのペーストも行われておりませんでした。

    上記のVBAについて、どのように修正すればよいのか、教示していただけないでしょうか?
    お手数をおかけしますが、よろしくお願いします。

    2017年3月5日 13:19

すべての返信

  • ネットで見つけて自分用にアレンジしたものですが、参考にならないでしょうか?

    Sub 転記先ブックに値貼り付け()
        Dim Fdir As String, FPas As String, FileName As String
        Dim gyou As Range
        Dim gyounum As Long          '見つかった行の番号
        Dim SAKIBK As Workbook       '転記先ブック
        Dim MOTOSH As Worksheet      '転記元ブックの転記元シート
        Dim SAKISH As Worksheet      '転記先ブックの転記先シート
        Dim moto As Long, saki As Long, i As Long, tuika As Long
        Application.ScreenUpdating = False
        Fdir = "F:\"                 '転記先ブックのフォルダ
        FPas = Fdir & "転記先ブック.xlsx"
        FileName = FPas
        Set SAKIBK = Workbooks.Open(FileName)
        '転記先と転記元のシートをセット
        Set SAKISH = SAKIBK.Worksheets("転記先シート")
        Set MOTOSH = Workbooks("転記元ブック.xlsm").Worksheets("転記元シート")
        '番号を検索してその行にコピペする
        moto = MOTOSH.Cells(Rows.Count, 1).End(xlUp).Row  '転記元の最後の行
        saki = SAKISH.Cells(Rows.Count, 1).End(xlUp).Row  '転記先の最後の行
        For i = 2 To moto
            Set gyou = SAKISH.Range("A2:A" & saki).Find(MOTOSH.Cells(i, 1), lookat:=xlWhole)
            If Not gyou Is Nothing Then
                gyounum = gyou.Row
                MOTOSH.Range("A" & i & ":" & "D" & i).Copy
                SAKISH.Range("A" & gyounum).PasteSpecial Paste:=xlValues
            Else
                tuika = tuika + 1   '見つからない場合は最後の行の次に追加
                MOTOSH.Range("A" & i & ":" & "D" & i).Copy
                SAKISH.Range("A" & saki + tuika).PasteSpecial Paste:=xlValues
            End If
        Next
        SAKISH.Activate
        Application.CutCopyMode = False
        Application.ScreenUpdating = True
        '転記先ブックは転記を確認して手動で閉じる
    End Sub

    尚、私は未熟者ですので突っ込んだ質問にはお答えできかねますので悪しからずご了承くださいませ。

    2017年3月21日 23:11
  • TETUO様、対応していただいて、誠にありがとうございます。

    回答に基づき、下記のとおり組んでみました。

    Sub YシートからVシート貼り付け()

        Dim Fdir As String, FPas As String, FileName As String
        Dim gyou As Range
        Dim gyounum As Long          '見つかった行の番号
        Dim SAKIBK As Workbook       '転記先ブック
        Dim MOTOSH As Worksheet      '転記元ブックの転記元シート
        Dim SAKISH As Worksheet      '転記先ブックの転記先シート
        Dim moto As Long, saki As Long, i As Long, tuika As Long
      
         Application.ScreenUpdating = False
      
         FPas = ThisWorkbook.Worksheets("Zシート").Range("ブックYの保存場所及びファイル名の記載のあるセル")
         FileName = FPas
         Set SAKIBK = Workbooks.Open(FileName)
      
       '転記先と転記元のシートをセット
         Set SAKISH = SAKIBK.Worksheets("Vシート").Range("ブックYのシート名の記載のあるセル")
          Set MOTOSH = ThisWorkbook.Worksheets("Yシート")
         
       '番号を検索してその行にコピペする
        moto = MOTOSH.Cells(Rows.Count, 1).End(xlUp).Row  '転記元の最後の行
        saki = SAKISH.Cells(Rows.Count, 1).End(xlUp).Row  '転記先の最後の行
        For i = 2 To moto
              Set gyou = SAKISH.Range("A2:A" & saki).Find(MOTOSH.Cells(i, 1), lookat:=xlWhole)
              If Not gyou Is Nothing Then
                  gyounum = gyou.Row
                  MOTOSH.Range("A" & i & ":" & "D" & i).Copy
                  SAKISH.Range("A" & gyounum).PasteSpecial Paste:=xlValues
              Else
                  tuika = tuika + 1   '見つからない場合は最後の行の次に追加
                 MOTOSH.Range("A" & i & ":" & "D" & i).Copy
                  SAKISH.Range("A" & saki + tuika).PasteSpecial Paste:=xlValues
              End If
          Next
         
         If (Not SAKIBK.Saved) Then
              Call SAKIBK.Save    '転記先ブックを保存
             'Call SAKIBK.Close    '転記先ブックを閉じる
        End If

    End Sub

    実行した結果、Xブックは開いたものの、「型が一致しません。」のエラーが出て、最後まで実行できません。
    自分も未熟者なので、どこで型の不一致が生じているのか、分からない状況です。
    (Vシートの整理番号のタイトルのセルと、Yシートの整理番号タイトルのセルとが同一場所でないことが、原因かもしれません。しかし、そうかどうかは不明です。)

    お手数をおかけしますが、引き続き、よろしくお願いします。

    2017年3月22日 0:50
  • >Vシートの整理番号の整理番号のタイトルのセルがA4セルにある
    のなら
    Set gyou = SAKISH.Range("A2:A" & saki).Find(MOTOSH.Cells(i, 1), lookat:=xlWhole)

    Set gyou = SAKISH.Range("A5:A" & saki).Find(MOTOSH.Cells(i, 1), lookat:=xlWhole)
    としたら如何でしょうか?

    これでもうまくいかなかったら私にもわかりませんので
    熟練者の回答をお待ちください。

    2017年3月22日 1:59
  • TETUO様、引き続きの回答、ありがとうございます。

    実行しましたが、型が一致しませんのエラーが出て、Yシートが開いたところで止まってしまいました。

    お手数をおかけしますが、引き続き、よろしくお願いします。

    2017年3月22日 2:12
  • 私の場合はエラーも出ず実行できましたので
    何故「型が一致しません」になるのか分かりません。
    お役に立てずごめんなさい。
    熟練者の回答を待ちましょう。

    2017年3月22日 2:34
  • 誠に申し訳ありませんが、追加の質問があります。

    Zシートで「データ1」が空白となっている整理番号の行が一部で存在します。
    このままYシートに貼り付けると、Yシートで当該整理番号で「データ1」の記述があった場合に空白が上書きされて消去してしまいます。

    そのため、
    『Zシートの各行で、「データ1」が空白となっている整理番号の行は、VBAを実行したい場合は、何もしない。』
    を行いたいのですが、どこにどのような記述を追加すればよろしいでしょうか?

    If (『データ1』 Is Nothing) Then

    『処理を何もしない。』

    End If

    までは分かったのですが、ここから先が分かりません。

    お手数をおかけしますが、引き続き、よろしくお願いします。

    2017年3月22日 13:09
  • 整理番号だけの行はコピペをスキップする場合
    私のシート構成では下記のようにしたら実行できました。
    (もっとスマートな方法があると思いますが)

    Sub 転記先ブックに値貼り付けその2()
        Dim Fdir As String, FPas As String, FileName As String
        Dim gyou As Range
        Dim gyounum As Long          '見つかった行の番号
        Dim SAKIBK As Workbook       '転記先ブック
        Dim MOTOSH As Worksheet      '転記元ブックの転記元シート
        Dim SAKISH As Worksheet      '転記先ブックの転記先シート
        Dim moto As Long, saki As Long, i As Long, tuika As Long
        Application.ScreenUpdating = False
        Fdir = "F:\"                 '転記先ブックのフォルダ
        FPas = Fdir & "転記先ブック.xlsx"
        FileName = FPas
        Set SAKIBK = Workbooks.Open(FileName)
        '転記先と転記元のシートをセット
        Set SAKISH = SAKIBK.Worksheets("転記先シート")
        Set MOTOSH = Workbooks("転記元ブック.xlsm").Worksheets("転記元シート")
        '番号を検索してその行にコピペする
        moto = MOTOSH.Cells(Rows.Count, 1).End(xlUp).Row  '転記元の最後の行
        saki = SAKISH.Cells(Rows.Count, 1).End(xlUp).Row  '転記先の最後の行
        For i = 2 To moto
            Set gyou = SAKISH.Range("A2:A" & saki).Find(MOTOSH.Cells(i, 1), lookat:=xlWhole)
            If Not gyou Is Nothing Then
                gyounum = gyou.Row
                If MOTOSH.Range("B" & i) <> "" Then        'B~D列が空白でない場合
                    MOTOSH.Range("A" & i & ":" & "D" & i).Copy
                    SAKISH.Range("A" & gyounum).PasteSpecial Paste:=xlValues
                Else
                    GoTo tugi       '★B~D列が空白の場合はスキップする★
                End If
            Else
                tuika = tuika + 1   '見つからない場合は最後の行の次に追加
                MOTOSH.Range("A" & i & ":" & "D" & i).Copy
                SAKISH.Range("A" & saki + tuika).PasteSpecial Paste:=xlValues
            End If
    tugi:
        Next
        SAKISH.Activate
        Application.CutCopyMode = False
        Application.ScreenUpdating = True
        '転記先ブックは転記を確認して手動で閉じる
    End Sub

    2017年3月22日 22:37
  • TETUO様、引き続き対応していただいて、誠にありがとうございます。

    回答に基づき、下記のとおり組んでみました。

    Sub YシートからVシート貼り付け()

        Dim Fdir As String, FPas As String, FileName As String
        Dim gyou As Range
        Dim gyounum As Long          '見つかった行の番号
        Dim SAKIBK As Workbook       '転記先ブック
        Dim MOTOSH As Worksheet      '転記元ブックの転記元シート
        Dim SAKISH As Worksheet      '転記先ブックの転記先シート
        Dim moto As Long, saki As Long, i As Long, tuika As Long
     
        Application.ScreenUpdating = False
     
        FPas = ThisWorkbook.Worksheets("Zシート").Range("ブックYの保存場所及びファイル名が記載されているセル")
        FileName = FPas
        Set SAKIBK = Workbooks.Open(FileName)
     
      '転記先と転記元のシートをセット
         Set SAKISH = ThisWorkbook.Worksheets("Zシート").Range("Vシートのシート名が記載されているセル")
         Set MOTOSH = ThisWorkbook.Worksheets("Zシート")
        
      '番号を検索してその行にコピペする
        moto = MOTOSH.Cells(Rows.Count, 1).End(xlUp).Row  '転記元の最後の行
        saki = SAKISH.Cells(Rows.Count, 1).End(xlUp).Row  '転記先の最後の行
        For i = 2 To moto
             Set gyou = SAKISH.Range("A2:A" & saki).Find(MOTOSH.Cells(i, 1), lookat:=xlWhole)
             If Not gyou Is Nothing Then
                 gyounum = gyou.Row
                 MOTOSH.Range("A" & i & ":" & "D" & i).Copy
                 SAKISH.Range("A" & gyounum).PasteSpecial Paste:=xlValues
             Else
                 tuika = tuika + 1   '見つからない場合は最後の行の次に追加
                 MOTOSH.Range("A" & i & ":" & "D" & i).Copy
                 SAKISH.Range("A" & saki + tuika).PasteSpecial Paste:=xlValues
             End If
         Next
        
        If (Not SAKIBK.Saved) Then
             Call SAKIBK.Save    '転記先ブックを保存
             Call SAKIBK.Close   '転記先ブックを閉じる
         End If

    End Sub

    実行した結果、再度、型が一致しませんのエラーが出て、Yシートが開いたところで止まってしまいました。

    お手数をおかけしますが、引き続き、よろしくお願いします。

    2017年3月23日 0:47
  • '転記先と転記元のシートをセット
         Set SAKISH = ThisWorkbook.Worksheets("Zシート").Range("Vシートのシート名が記載されているセル")
         Set MOTOSH = ThisWorkbook.Worksheets("Zシート")
    の箇所を

    ①案

    '転記先と転記元のシートをセット
         Dim Vname As String
         Vname = ThisWorkbook.Worksheets("Zシート").Range("Vシートのシート名が記載されているセル").Value
         Set SAKISH = SAKIBK.Worksheets(Vname)
         Set MOTOSH = ThisWorkbook.Worksheets("Zシート")

    としてみたら如何でしょう?

    ②案 Vシートのシート名が「Vシート」なら

    '転記先と転記元のシートをセット
       Set SAKISH = SAKIBK.Worksheets("Vシート")
         Set MOTOSH = ThisWorkbook.Worksheets("Zシート")

    としてみたら如何でしょう?

    どちらもダメでしたらごめんなさい。私には分かりません。

    2017年3月23日 1:55
  • TETUO様、引き続き対応していただいて、誠にありがとうございます。

    VBAを実行したところ、転記は成功しました。

    しかし、Zシートに無い整理番号のデータがYシートに記載されていたのですが、それが消えてしまっていました。

    『Zシートの各行で、「データ1」が空白となっている整理番号の行は、VBAを実行したい場合は、何もしない。』

    が、正しく実行されてないようです。

    お手数をおかけしますが、引き続き、よろしくお願いします。

    2017年3月23日 3:01
  • ループの箇所①を②のようにしたら私の場合うまくいったのですが、、、、

    -------------------①----------------------------------------------------------
     '(転記先シートのA4に「整理番号」とある場合)
     
        For i = 2 To moto
              Set gyou = SAKISH.Range("A5:A" & saki).Find(MOTOSH.Cells(i, 1), lookat:=xlWhole)
              If Not gyou Is Nothing Then
                  gyounum = gyou.Row
                  MOTOSH.Range("A" & i & ":" & "D" & i).Copy
                  SAKISH.Range("A" & gyounum).PasteSpecial Paste:=xlValues
              Else
                  tuika = tuika + 1   '見つからない場合は最後の行の次に追加
                 MOTOSH.Range("A" & i & ":" & "D" & i).Copy
                  SAKISH.Range("A" & saki + tuika).PasteSpecial Paste:=xlValues
              End If
       Next
    -------------------②------------------------------------------------------------
       For i = 2 To moto
            Set gyou = SAKISH.Range("A5:A" & saki).Find(MOTOSH.Cells(i, 1), lookat:=xlWhole)
            If Not gyou Is Nothing Then
                gyounum = gyou.Row
                If MOTOSH.Range("B" & i) <> "" Then        'B~D列が空白でない場合
                    MOTOSH.Range("A" & i & ":" & "D" & i).Copy
                    SAKISH.Range("A" & gyounum).PasteSpecial Paste:=xlValues
                Else
                    GoTo tugi       '★B~D列が空白の場合はスキップする★
                End If
            Else
                tuika = tuika + 1   '見つからない場合は最後の行の次に追加
                MOTOSH.Range("A" & i & ":" & "D" & i).Copy
                SAKISH.Range("A" & saki + tuika).PasteSpecial Paste:=xlValues
            End If
    tugi:
       Next
    ----------------------------------------------------------------------------------

    2017年3月23日 5:15
  • TETUO様、引き続きの回答、ありがとうございます。

    実行した結果、ようやく、目的の動作を確認することができました。

    この場をお借りして、厚く御礼申し上げます。

    2017年3月23日 13:31