Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

10655 / 76734

←次へ　｜　前へ→


	【71625】Re:別ファイルを指定

UO3 - 12/3/23(金) 14:32 -


	引用なし

	パスワード

▼Ｇ一朗さん：

質問の回答をもらっていない段階ですが、コード案を３つ。

Sample1 は、アップされた方式、１行ごとにファイルを開いて転記するタイプ。
ただし、この場合、２行目が、また同じファイルかもしれません。
そうすると、同じブックを二度開こうとしてエラーになります。
ですので、毎回開いて、保存して閉じるということをしなければいけません。

Sample2　は　転記元ブックと転記先ブックが、それぞれ１つというタイプ。
最初の行でのみ、転記元ブックと転記先ブックを開きます。

さらに、Sample3は、Sample2の別案。開くファイルは転記先ブックのみです。

Sub Sample1()
　　Dim c As Range
　　Dim d As Variant
　　
　　Application.ScreenUpdating = False
　　
　　With ThisWorkbook.Sheets("Sheet1")
　　　　For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
　　　　　　Workbooks.Open c.Value
　　　　　　d = ActiveWorkbook.Sheets(c.Offset(, 1).Value).Range(c.Offset(, 2).Value).Value
　　　　　　ActiveWorkbook.Close False
　　　　　　Workbooks.Open c.Offset(, 3).Value
　　　　　　ActiveWorkbook.Sheets(c.Offset(, 4).Value).Range(c.Offset(, 5).Value).Value = d
　　　　　　ActiveWorkbook.Close True
　　　　Next
　　End With
　　
　　Application.ScreenUpdating = True
　　MsgBox "処理が終了しました"
　
　　
End Sub

Sub Sample2()
　　Dim c As Range
　　Dim d As Variant
　　Dim done As Boolean
　　Dim wb2 As Workbook, wb3 As Workbook
　　
　　Application.ScreenUpdating = False
　　
　　With ThisWorkbook.Sheets("Sheet1")
　　　　For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
　　　　　　If Not done Then
　　　　　　　　Set wb2 = Workbooks.Open(c.Value)
　　　　　　　　Set wb3 = Workbooks.Open(c.Offset(, 3).Value)
　　　　　　　　done = True
　　　　　　End If
　　　　　　
　　　　　　wb3.Sheets(c.Offset(, 4).Value).Range(c.Offset(, 5).Value).Value = _
　　　　　　　　　　wb2.Sheets(c.Offset(, 1).Value).Range(c.Offset(, 2).Value).Value
　　　　　　　　　　
　　　　Next
　　End With
　　
　　wb2.Close False
　　wb3.Close True
　　
　　Set wb2 = Nothing
　　Set wb3 = Nothing
　　
　　Application.ScreenUpdating = True
　　MsgBox "処理が終了しました"
　　
End Sub

Sub Sample3()
　　Dim c As Range
　　Dim d As Variant
　　Dim done As Boolean
　　Dim wb3 As Workbook
　　Dim myPath As String
　　Dim fName As String
　　Dim w As Variant
　　
　　Application.ScreenUpdating = False
　　
　　With ThisWorkbook.Sheets("Sheet1")
　　　　For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
　　　　　　If Not done Then
　　　　　　　　Set wb3 = Workbooks.Open(c.Offset(, 3).Value)
　　　　　　　　w = Split(c.Value, "\")
　　　　　　　　fName = w(UBound(w))
　　　　　　　　myPath = Left(c.Value, Len(c.Value) - Len(fName))
　　　　　　　　done = True
　　　　　　End If
　　　　　　With wb3.Sheets(c.Offset(, 4).Value).Range(c.Offset(, 5).Value)
　　　　　　　　.Formula = "='" & myPath & "[" & fName & "]" & c.Offset(, 1).Value & "'!" & c.Offset(, 2).Value
　　　　　　　　.Value = .Value
　　　　　　End With
　　　　　　
　　　　Next
　　End With
　　
　　wb3.Close True
　　
　　Set wb3 = Nothing
　　
　　Application.ScreenUpdating = True
　　MsgBox "処理が終了しました"
　　
End Sub

4 hits

▼

【71620】別ファイルを指定 Ｇ一朗 12/3/23(金) 13:23