|
ちょっちまとめてみた。
環境がないので動く保証はないです。
Sub マクロA()
Dim destSheet As Worksheet
Dim srcBook As Workbook
Dim srcSheet As Worksheet
Dim r As Range
Dim fileName As Variant
' コピー元のファイル名の取得
fileName = Application.GetOpenFilename("すべてのファイル,*.*")
If fileName <> False Then
Set srcBook = Workbooks.Open(fileName)
Else
Exit Sub
End If
' コピー先のシートを設定
Set destBook = Workbooks("マクロ.xls").Sheets("データ")
' コピー
For Each r In destSheet.Range("B3:H3")
On Error Resume Next
Set srcSheet = srcBook.Worksheets(r.Text)
If Err.Number <> 0 Then
MsgBox "'" & r.Text & "'というシートが存在しません。"
Exit For
End If
On Error GoTo 0
srcSheet.Range("AD20:AD22").Copy
r.Offset(1).PasteSpecial xlPasteValues
srcSheet.Range("F37").Copy
r.Offset(4).PasteSpecial xlPasteValues
srcSheet.Range("AF6").Copy
r.Offset(5).PasteSpecial xlPasteValues
Next
Set destSheet = Nothing
Set srcBook = Nothing
Set srcSheet = Nothing
Application.CutCopyMode = False
End Sub
|
|