質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

89.63%

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

解決済

回答 3

投稿

  • 評価
  • クリップ 2
  • VIEW 204

Mkasai

score 4

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

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

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

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

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

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

質問への追記・修正、ベストアンサー選択の依頼

  • yuuskeccho

    2020/02/13 12:26

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

    キャンセル

回答 3

checkベストアンサー

+2

もし、コードをどう記述したらいいのかわからない場合は、マクロの自動記録を使うと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

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

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2020/02/14 16:15

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

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

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

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

    キャンセル

  • 2020/02/14 18:09 編集

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

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

    キャンセル

  • 2020/02/17 13:44

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

    キャンセル

0

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

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

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("作成情報")

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

0

他の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

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2020/02/13 13:08

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

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 89.63%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる