Excel シートの取り込みとデータ検出方法

質問

Excel 2013にて、指定したxlsxファイルの全シートをコピーし、セルのデータを検出する方法をご教示下さい。

当方、あまりマクロを組んだ経験がないため、ご存じの方ご教示下さると幸いです。
主題は上に書いたとおり、

(1)現在アクティブなブックから、参照ボタンでA1セルへ対象ファイルの絶対パスを表示します(現在はGetOpenFilenameで、A1セルに対象のブックのパスを表示しています。)

(2)次のボタンを押すと、GetOpenFilenameにて取得した対象ファイルの全シートを、現在アクティブなブックにコピーします。

(3)コピーしてくる際、コピーされたシート内に、例として『東京都』という文字があるセルは赤にします。こちらを参考にしました。
http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1152147211

コピー元、コピー先の両方に、名前が被るシート名などはないため、その辺の回避はしなくてOKなのですが。

ほぼ1からで大変お手数ですが、ご教示頂ける方、ご回答下されば幸いです。
よろしくお願い申し上げます。

回答No.2

tom04 · ベストアンサー

No.1です。
ブックを開かずに！というのは↓のサイトにあるようにExcel4.0なるものを使用すれば可能のようです。

http://officetanaka.net/excel/vba/tips/tips28.htm

ただ結構面倒な感じがしますので、
画面更新をせず「コピー元ファイル」を開き　→　そのファイルの各Sheetをコピー＆ペースト　→　条件セルに色付け　→　「コピー元ファイル」を閉じる
といった操作ではどうでしょうか？

そして
＞fN = Cells(1, 1)をSet wB = Workbooks(fN)にて変数で代入すると・・・
に関しては
Application.GetOpenFilenameでA1セルに保存場所のパスとファイル名が取得できている！というコトですので、
変数に格納せずそのままA1セルの「文字列」（保存場所のパス＆ファイル名）を使用してはどうでしょうか？

Sub Sample2()
Dim wS As Worksheet, wB As Workbook
Dim k As Long, c As Range, myRng As Range

Application.ScreenUpdating = False
'▼　GetOpenFilename　でA1セルにコピー元のパスとファイル名が取得できているという前提
Workbooks.Open (Range("A1"))

Set wB = ActiveWorkbook
ThisWorkbook.Activate
For k = 1 To wB.Worksheets.Count
Worksheets.Add after:=ActiveWorkbook.Worksheets(Worksheets.Count)
Set wS = ActiveSheet
wS.Name = wB.Worksheets(k).Name & "(" & k & ")" '←念のため★
wB.Worksheets(k).Cells.Copy wS.Range("A1")
Set myRng = wS.Cells.Find(what:="東京都", LookIn:=xlValues, lookat:=xlPart)
If Not myRng Is Nothing Then
For Each c In wS.UsedRange
If InStr(c, "東京都") > 0 Then
Set myRng = Union(myRng, c)
End If
Next c
myRng.Interior.ColorIndex = 3
End If
Next k
wB.Close
Application.ScreenUpdating = True
End Sub

※　とりあえずこちらで
A1セルにApplication.GetOpenFilenameで
選択したファイルの「パスとファイル名」を取得しやってみたところ
一応動作確認はできています。m(_ _)m

お礼

わざわざ検証までしていただき、ありがとうございました。
心より厚く御礼申し上げます。

こちらでも頂戴いたしましたマクロが希望通りに動くことが確認出来ました。
これでかなり業務を圧縮出来そうです。本当にありがとうございました。
また、マクロの組み方、考え方も大変勉強になりましたので、今後必要なときに是非参考にさせて頂きます。

重ねて御礼申し上げます。大変助かりました。。
よろしくお願いいたします。

回答No.1

tom04

こんばんは！
なかなか回答が付かないようですので・・・

（1）の部分が判り難いので、コード内に保存場所のパスとファイル名を記載する方法にしてみました。

標準モジュールです。

Sub Sample1()
Dim myPath As String, fN As String, wS As Worksheet, wB As Workbook
Dim k As Long, c As Range, myRng As Range, myFlg As Boolean

myPath = "保存場所のパス\"
fN = "ファイル名.xlsx" '←拡張子は適宜変更
'▼コピー元Bookが開いていない場合はそのBookを開く
For k = 1 To Workbooks.Count
If Workbooks(k).Name = fN Then
myFlg = True
End If
Next k
If myFlg = False Then
Workbooks.Open (myPath & fN)
End If
'▼コピー元Bookを変数「wB」に格納
Set wB = Workbooks(fN)
'▼「コピー先」Bookの最終Sheet以降にSheet追加し、「コピー元」Sheetをコピー（Sheet名もコピー元Sheet名に）
ThisWorkbook.Activate
For k = 1 To wB.Worksheets.Count
Worksheets.Add after:=ActiveWorkbook.Worksheets(Worksheets.Count)
Set wS = ActiveSheet
wS.Name = wB.Worksheets(k).Name & "(" & k & ")" '←念のため★
wB.Worksheets(k).Cells.Copy wS.Range("A1")
Set myRng = wS.Cells.Find(what:="東京都", LookIn:=xlValues, lookat:=xlPart)
If Not myRng Is Nothing Then
For Each c In wS.UsedRange
If InStr(c, "東京都") > 0 Then
Set myRng = Union(myRng, c)
End If
Next c
myRng.Interior.ColorIndex = 3
End If
Next k
End Sub

※　コピー元ファイルが開いていない場合は開いて操作するようにしています。
＞コピー元、コピー先の両方に、名前が被るシート名などはないため・・・
とありますので、
コード内の
＞wS.Name = wB.Worksheets(k).Name & "(" & k & ")" '←念のため★
の行は
＞wS.Name = wB.Worksheets(k).Name
でも大丈夫かもしれません。m(_ _)m

補足

ご回答ありがとうございました。大変感謝申し上げます。
頂戴いたしましたマクロが実行出来ました。ありがとうございました。

ただ、コピー元のファイルをマクロに記述する方法を避けたく、
GetOpenFilenameにて取得したコピー元ファイルまでのフルパスを使いたいと考えております。

具体的には、ボタン(1)にてコピー元ファイルを指定し、そのファイルへのフルパスをセルA1へ取り込むようにしています。
ボタン(2)を押すと、指定したファイルの全シートを現在アクティブなブックへコピーしたいのです。
また、その際コピー元のブックを開く必要はありませんので、処理を削除させていただきました。すみません。

試行錯誤し、fN = Cells(1, 1)をSet wB = Workbooks(fN)にて変数で代入すると、「インデックスが有効範囲でない」エラーが出ます。
これはWorkbooksに対してフルパスでの記述が出来ないため、というのは分かったのですが、解決策が分からずじまいです。

現在も色々調べながらやっていますが、どうかお知恵を拝借できれば幸いです。

よろしくお願い申し上げます。