抽出したデータを別ブックに貼り付ける

Question

エクセルで「契約情報」というブックに”契約情報”と”作成情報”というシートがあります。
”契約情報”シートで選んだ情報を”作成情報”シートに抽出して貼り付けるというところはできました。

これを”作成情報”シートへ抽出するのではなく、別の「書類作成」という別ブックの”作成情報”シートに抽出したいのですが、うまくいきません。

「契約情報」と「書類作成」ブックは同じフォルダーにあります。

現在のコードは次のとおりです。

Sub 抽出()

Worksheets("作成情報").Range("2:11").ClearContents

Dim ws1, Sakusei
Dim StartRow, EndRow, tmpRow

'シート名を変えてる場合は適宜変更
Set ws1 = Worksheets("契約情報")
Set ws2 = Worksheets("作成情報")
'作成情報シートに指定されている抽出条件
Sakusei = ws2.Cells(1, "N")

StartRow = 2
EndRow = ws1.Cells(Rows.Count, "C").End(xlUp).Row
tmpRow = 2

For i = StartRow To EndRow
If (ws1.Cells(i, "M") = Sakusei) Then
ws2.Cells(tmpRow, "N") = Sakusei
ws2.Cells(tmpRow, "C") = ws1.Cells(i, "C")
ws2.Cells(tmpRow, "D") = ws1.Cells(i, "D")
ws2.Cells(tmpRow, "E") = ws1.Cells(i, "E")
ws2.Cells(tmpRow, "F") = ws1.Cells(i, "F")
ws2.Cells(tmpRow, "G") = ws1.Cells(i, "G")
ws2.Cells(tmpRow, "H") = ws1.Cells(i, "H")
ws2.Cells(tmpRow, "I") = ws1.Cells(i, "I")
ws2.Cells(tmpRow, "J") = ws1.Cells(i, "J")
ws2.Cells(tmpRow, "K") = ws1.Cells(i, "K")
tmpRow = tmpRow + 1
End If
Next

End Sub

Comments

[yuuskeccho]

コードを記載する場合はマークダウンを使いましょう。
https://teratail.com/help#about-markdown

Answer 1

もし、コードをどう記述したらいいのかわからない場合は、マクロの自動記録を使うとExcelが勝手にコードを記述してくれます。
それを追うとどのようなコードを記述すればよいのかわかると思います。

  'シートをコピーしたいのであれば
  Workbooks("契約情報").Sheets("作成情報").Copy

  'いきなり別ブックに出力したいのであれば
  Workbooks.Add
  With ActiveWorkbook
    .Sheets(1).Name = "作成情報"
    
     '---------- 必要な処理をここに書く -----------
  End With

こんな感じです。

ただ、新たにブックが作成されると新しいブックがアクティブになるので注意して下さい。

---

追記です。コードを書くとしたらこんな感じでしょうか。

Sub 抽出()
  Dim ws1 As Worksheet, ws2 As Worksheet
  Dim Sakusei As String
  Dim StartRow As Long, EndRow As Long, tmpRow As Long
  Dim i As Long
  Dim strFilePath As String, strFileName As String
  Dim intFFile As Integer
  Dim blnWbOpen As Boolean
  Dim varTmp As Variant
  
  strFilePath = ThisWorkbook.Path & "\"
  strFileName = "書類作成.xlsx"
  
  '----- ファイルの存在確認
  If Dir(strFilePath & strFileName) = "" Then
    MsgBox strFilePath & strFileName & " が見つかりません", vbCritical
    Exit Sub
  End If
  
  blnWbOpen = False
  
  '----- 書き込みできる状態か？
  On Error Resume Next
  intFFile = FreeFile
  Open strFilePath & strFileName For Binary Access Read Lock Read As #intFFile
  Close #intFFile
  
  If Err.Number = 0 Then
    '開く！！
    Workbooks.Open strFilePath & strFileName
  Else
    '開かれているか確認する！！
    For Each varTmp In Workbooks
      If varTmp.FullName = strFilePath & strFileName Then
        
        blnWbOpen = True
      End If
    Next
    
    '誰かに開かれている！！
    If Not blnWbOpen Then
      MsgBox strFilePath & " を開くことができません。" & vbCrLf _
        & "誰かが開いている可能性があります"
      Exit Sub
    End If
  End If
  On Error GoTo 0
  
  
  
  'シート名を変えてる場合は適宜変更
  Set ws1 = Workbooks("契約情報").Sheets("契約情報")
  Set ws2 = Workbooks(strFileName).Sheets("作成情報")
  
  ws2.Range("2:11").ClearContents
  
  '作成情報シートに指定されている抽出条件
  Sakusei = ws2.Cells(1, "N")
  
  EndRow = ws1.Cells(Rows.Count, "C").End(xlUp).Row
  
  StartRow = 2
  tmpRow = 2
  
  For i = StartRow To EndRow
    If (ws1.Cells(i, "M") = Sakusei) Then
      
      ws2.Cells(tmpRow, "N") = Sakusei
      
      ws2.Cells(tmpRow, "C") = ws1.Cells(i, "C")
      ws2.Cells(tmpRow, "D") = ws1.Cells(i, "D")
      ws2.Cells(tmpRow, "E") = ws1.Cells(i, "E")
      ws2.Cells(tmpRow, "F") = ws1.Cells(i, "F")
      ws2.Cells(tmpRow, "G") = ws1.Cells(i, "G")
      ws2.Cells(tmpRow, "H") = ws1.Cells(i, "H")
      ws2.Cells(tmpRow, "I") = ws1.Cells(i, "I")
      ws2.Cells(tmpRow, "J") = ws1.Cells(i, "J")
      ws2.Cells(tmpRow, "K") = ws1.Cells(i, "K")
      
      tmpRow = tmpRow + 1
    End If
  Next
  
  
  '処理完了メッセージ
  MsgBox "処理が完了しました！", vbInformation

End Sub

なお、対象ブック内のシート存在確認はしていません。
あと、作成後の保存等も記述していません。

Comments

[Mkasai]

ありがとうございました。
マクロを実行してみたところ、’U:￥帳票作成￥書類作成.xlsx'が見つかりません。移動、名前の変更、または削除された可能性があります。と出て、アクセスできないいずれかの理由として、
ファイル名またはパスが存在しません。
ファイルが他のプログラムによって使用されています。
保存しようしているブックと同じ名前のブックが現在開かれています。
と出ます。
どのように修正したら動くのでしょうか。
お手数をお掛け致しますが、よろしくお願いします。

[yuuskeccho]

どのようなコードを実行してみたのでしょうか？
ブックが開かれているのであればファイルが見つからない等のメッセージは本件とは関係ないと思いますが。

コードの中で、出力先ブックの存在確認→ブックを開く→転記処理→出力先ブックを上書き保存→出力先ブックを閉じる・・・といった流れを組みたいということでしょうか？
質問がうまくいきませんではこちらもよくわかりません。質問内容を最終的にどのようにしたいのか明確にした方が良いと思います。

上に何となく書いたコード追加しました。

[sinzou]

「ファイルが使用されている」（読み取り専用）
ドライブ　U：　サーバーフォルダーですか？
一度すべてのEXCEL終了させてから、ためしてみては？

[Mkasai]

度々お世話になります。
先日別の質問で条件に一致したセルに〇をつけるという動きについてお力をいただいたのですが、そのデータを使って、次の段階へ進みたいと思っています。

サーバー(U:)にある帳票作成というフォルダの中に、契約情報と書類作成の２つのブックがあります。
契約情報ブックの中には、契約情報と作成情報の２つのシートがあります。
書類作成ブックの中には、作成したい書類の雛型が複数シートあります。

契約情報ブックの契約情報シートから作成したいものを選択抽出し、その選んだ契約情報を書類作成ブックから帳票として印刷したい。

契約情報ブックの作成情報シートは、自分のスキルが低い為準備しているだけなので、直接書類作成ブックから帳票が作成できるのであれば必要ない。

契約情報ブックの作成情報シートをそのまま書類作成ブックにシートごとコピーして使えないかと考えていました。
でもなかなか思うように作ることができず、質問させていただきました。

書類作成ブックは開いていても開いていなくても使えるようにしたい。
保存は不要。

こちらが作りたいものの動きです。
お力お貸しください。
よろしくお願いします。

[sinzou]

https://tonari-it.com/excel-vba-invoice-macro/
【初心者向けエクセルVBA】取引先別に請求書を作成するマクロを作る

一度読まれてみてはいかがでしょうか。

[yuuskeccho]

ん～、色々ツッコミどころがあるようですね。

普通ひな形というのは、直接触らないで、コピーして使うものではないのでしょうか？
だとすれば、ひな形が入っているブックにシートをコピーするとか値を直接書き込むというのはナンセンスで、ひな形をコピーして使うというのが本来の使い方な気がします。
仮にひな形に書き込むとしても僕が追記したコードは実行してみましたか？

それで足りないというのであれば、何が足りないのでしょうか？
あと、質問内容や主旨が変わってくるのであれば、質問自体を訂正して下さい。

それとスキルが低くてという謙遜は必要ありませんし、最初からスキルを持っている人はいません。
どの部分がどのようにわからないのかを質問して教えてもらい、学習したうえで自身で解決するためにこのteratailがあるわけです。

[sinzou]

そうですね、「発行済み」ブックに「作成情報」シートコピーして、値を貼り付け、印刷、保存とかありそうですけど。
まず、’U:￥帳票作成￥書類作成.xlsx'ファイルその場所にありますか、半角スペース等も注意してください。

Yuusukecchoさんのコード、ｐｃ立ち上げ最初に実行してもエラー出ますか？
他の方も作業がありひらいたりしてませんか？

[Mkasai]

ありがとうございました。
ファイルの場所を確認してみるようアドバイスいただいて気が付きました。
拡張子が違っていました。
xlsxをxlsmに修正したら思っていた動きをするようになりました。
ありがとうございました。

Answer 2

他のExcelを使う場合、ブックを操作する処理が必要ですね。
既に開いてる時に更にOpen処理で開こうとするとダイアログが出てしまうなど意外と面倒です。
このソースは既に開いている場合も閉じてる場合も対応できるように書いたものです。
それと複数の連続セルをコピーする場合はRangeで範囲指定した方が処理が速いです。

Sub 抽出()
    
    Dim twb, cwb As Workbook
    Dim curPath, Sakusei As String
    Dim ws1, ws2 As Worksheet
    Dim StartRow, EndRow, tmpRow As Integer
    Dim wb As Workbook, flag As Boolean
    
    Set twb = ThisWorkbook
    curPath = twb.Path
    
    'ブックが既に開いているかどうかチェック
    For Each wb In Workbooks
        If wb.Name = "書類作成.xlsx" Then
            flag = True
            Exit For
        End If
    Next wb
    '既に開いている場合
    If flag = True Then
        'オブジェクトにセット
        Set cwb = Workbooks("書類作成.xlsx")
        cwb.Activate
    Else
        '新規で開いてオブジェクトにセット
        Workbooks.Open Filename:=curPath & "\書類作成.xlsx"
        Set cwb = ActiveWorkbook
    End If
    
    'シート名を変えてる場合は適宜変更
    Set ws1 = twb.Worksheets("契約情報")
    Set ws2 = cwb.Worksheets("作成情報")
    
    ws2.Range("2:11").ClearContents

    '作成情報シートに指定されている抽出条件
    Sakusei = ws2.Cells(1, "N")
    
    StartRow = 2
    EndRow = ws1.Cells(Rows.Count, "C").End(xlUp).Row
    tmpRow = 2
    
    For i = StartRow To EndRow
        If (ws1.Cells(i, "M") = Sakusei) Then
            ws2.Cells(tmpRow, "N") = Sakusei
            '範囲コピー
            ws2.Range(ws2.Cells(tmpRow, "C"), ws2.Cells(tmpRow, "K")).Value = ws1.Range(ws1.Cells(i, "C"), ws1.Cells(i, "K")).Value
            tmpRow = tmpRow + 1
        End If
    Next

End Sub

Comments

[hatena19]

Dim twb, cwb As Workbook
の部分ですが、型指定はまとめてできませんので、一つずつする必要があります。
Dim twb As Workbook, cwb As Workbook
というように。
前者だと、twb はVariant型で宣言したことになります。（Variant型なのでエラーにはなりませんが。）

Answer 3

これを”作成情報”シートへ抽出するのではなく、別の「書類作成」という別ブックの”作成情報”シートに抽出したいのですが、うまくいきません。

「契約情報」と「書類作成」ブックは同じフォルダーにあります。

Set ws1 = Worksheets("契約情報")
Set ws2 = Worksheets("作成情報")

を下記のように書き換えればいいでしょう。

Dim ws1 As Worksheet, ws2 As Worksheet
Dim targetWb As Workbook

Set ws1 = ThisWorkbook.Worksheets("契約情報")
Set targetWb = Workbooks.Open("書類作成.xlsx")
Set ws2 = targetWb.Worksheets("作成情報")