| |
こんにちは。かみちゃん です。
>質問は01〜10までのファイルがあり、一つのファイルに一つのシートと
>なっています。シート名はファイル名と同じです。
>そこでこれらから セルH180 の値をコピーし Book1に
すでにponponさんからもコメントが出ていますが、fileとセル番号の条件に汎用性を持たせてみました。
Book1ではなく、マクロを記述したブックに、file、セル番号の条件をあらかじめ
記述しておくと、その隣のセルに値を書き出す方法です。
この際、ブックの存在とシートの存在をチェックして、存在しなければその旨の
メッセージを出力するようにしています。
Option Explicit
Sub Macro1()
Dim WorkbookPath As String, OpenFileName As String
Dim TargetAddress As String, TargetSheetName As String
Dim MaxRow As Long, RowNo As Long
Dim GetValue As String
'ブックのパス
'（例）このマクロが書かれたブックと同じフォルダの場合
WorkbookPath = ThisWorkbook.Path
'（例）特定のフォルダの場合（末尾に\はつけない）
'WorkbookPath = "C:\My Documents"
'抽出対象セル
TargetAddress = Range("B1").Value
'最大行
MaxRow = Range("A1").CurrentRegion.Rows.Count
For RowNo = 2 To MaxRow
'対象ブック名の取得
OpenFileName = WorkbookPath & "\" & Cells(RowNo, 1).Value & ".xls"
'対象シート名の取得
TargetSheetName = Cells(RowNo, 1).Value
'指定されたブックが存在するか
If Dir(OpenFileName) <> "" Then
'指定されたブックを開く
Workbooks.Open Filename:=OpenFileName
'指定されたシートが存在するか
If IsSheet(TargetSheetName) Then
'指定されたシートを選択する
Sheets(TargetSheetName).Select
'抽出対象セルで指定されたセルの値を取得する。
GetValue = Range(TargetAddress).Value
Else
GetValue = "シートが見つかりません"
End If
'指定されたブックを閉じる
ActiveWorkbook.Close
'取得した値を書き込む
Cells(RowNo, 2).Value = GetValue
Else
Cells(RowNo, 2).Value = "ファイルが見つかりません"
End If
Next
End Sub
'シート名存在チェック
Function IsSheet(strSheetName As String) As Boolean
Dim ws As Worksheet
'ブック内のシート名の比較を行う
MsgBox strSheetName
For Each ws In Worksheets
'.Nameプロパティのシート名と受け取ったstrSNAMEを比べる
If ws.Name = strSheetName Then
IsSheet = True '名前が一致したのでTrueをセット
Exit Function 'もうすること無いので関数を抜ける
End If
Next
'一つも一致しなかったので、Falseをセット
IsSheet = False
End Function
どうしても、Book1やマクロを記述したブックと別の新規ブックなどであれば、一
工夫必要かと思います。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
