「dポイント」が最大20倍になるお得な情報

同一フォルダ内にある複数のExcelブックから特定シートの特定セル値を抽出して一覧表にまとめるExcel マクロ(VBA)を教えてください。
下記の過去レスを参考に参照先やセルの位置情報を置き換え、実行しましたがデバッグがでてそれ以降
解決できず困っています。
https://oshiete.goo.ne.jp/qa/7640124.html

■元データ情報
・実行する端末のOSはWindows 7、Excelは2008
・対象フォルダは、デスクトップに「得意先」名で保存
 このフォルダに複数のブック(100ブック)があります。
・抽出したい対象は、各ブック内の「連絡先」シートの「B2:AN2」セルにあります。

■抽出一覧作成イメージ
・新たに「一覧表.xls」ブックとして、各ブックからB2:AN2の1行ずつを抽出し、
  100ブック分の値を1シート内に100行の一覧となるようにしたい。
・A列には抽出元ブック名(=ファイル名)を抽出したい。

いろいろ過去ログを参考に試行錯誤しましたが、どうしてもデバックとなります。
ご存知の方、上記フォルダ名、保管場所を書き込んだマクロを教えていただけないでしょうか?
どうぞ宜しくお願いいたします。

質問者からの補足コメント

  • tom04様へ

    先程、デバッグとなりました、と御礼のコメントにてお伝えさせていただきましたが、
    再度、個人マクロを開き、一覧表を開いた状態で実行したところ、
    1行もデータは抽出されませんでしたが、「完了」の文字は現れました。
    正常に実行されたように思うのですが、データが抽出されない理由がわかません。

    お時間が許されるようでしたら、対処方法をご教授頂けると助かります。
    どうぞよろしくお願いいたします。

      補足日時:2018/06/18 01:02

A 回答 (2件)

No.1です。



結局エラーは発生しなかったのですね?
以下のコトを確認してみてください。

① 前回のコードの
>Application.ScreenUpdating = False

>Application.ScreenUpdating = True
の2行を消去しマクロを実行。

画面上でファイルが開かれていればフォルダ内にファイルが存在するコトになりますので
マクロはちゃんと動いています。

となると、気になるのは
ファイル内に「連絡先」というシート名のシートが存在しない可能性があります。
コード内の
>sN = "連絡先"
で変数「sN」に「連絡先」というシート名を格納し、開いたブックの各シートを検索していき
「連絡先」というシート名のシートがある場合のみ
そのブックのファイル名と「連絡先」シートのB2:AN2セルの値を順に表示するようにしています。

こちらで考えられるといえばこの程度なのですが・・・m(_ _)m
    • good
    • 0

こんばんは!



>Excelは2008
というコトはMac版のExcelですかね?
Mac版で動くかどうか判りませんが、一例です。
コード記載ブックの「Sheet1」の1行目から表示するようにしています。

Sub Sample1()
 Dim k As Long, cnt As Long
 Dim myPath As String, fN As String, sN As String
 Dim wB As Workbook, wS As Worksheet
 Dim myFlg As Boolean
  myPath = "保存場所のパス" & "\"
  sN = "連絡先"
  fN = Dir(myPath & "*.xls*")
  Application.ScreenUpdating = False
   Do Until fN = ""
    Workbooks.Open (myPath & fN)
     Set wB = ActiveWorkbook
      For k = 1 To wB.Worksheets.Count
       If wB.Worksheets(k).Name = sN Then
        myFlg = True
        Exit For
       End If
      Next k
       If myFlg = True Then
        Set wS = wB.Worksheets(sN)
        cnt = cnt + 1
         With ThisWorkbook.Worksheets("Sheet1")
          .Cells(cnt, "A") = Left(fN, InStrRev(fN, ".") - 1)
          wS.Range("B2:AN2").Copy
          .Cells(cnt, "B").PasteSpecial Paste:=xlPasteValues
         End With
       End If
      Application.DisplayAlerts = False
       wB.Close
      Application.DisplayAlerts = True
       myFlg = False
       fN = Dir()
   Loop
    Application.ScreenUpdating = True
    MsgBox "完了"
End Sub

※ コード内の「保存場所のパス」の部分は
デスクトップのフォルダを開きどのファイルでも良いので
アイコン上で右クリック → プロパティ → 「場所」の部分がパスになりますので
そのままコピー&ペーストしてみてください。

※ 一つ一つファイルを開いていますので、
そこそこ時間を要すると思います。m(_ _)m
    • good
    • 0
この回答へのお礼

早々にご回答いただき、ありがとうございます。

頂いた回答をコピペし、「保存場所のバス」も書き換え、実行したところ、
「実行時エラー91’:オブジェクト変数またはWithブロック変数が設定されていません。」と表示され、デバッグを開くと、
For k = 1 To wB.Worksheets.Count
のラインを差します。

もしお時間許せば、再度ご教授頂けると助かります。

お礼日時:2018/06/18 00:39

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング