Excel VBA質問箱 IV

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

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


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

10653 / 76734

←次へ　｜　前へ→


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

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


	引用なし

	パスワード

▼Ｇ一朗さん：

もう１つ。　転記先ブックが複数ありうる場合のコード案です。
処理の最初に転記先ブック名で並び替えをします。
Sample3と同じく、転記先ブックのみを開きます。

Sub Sample4()
　　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")
　　　　.Cells.Sort key1:=Columns("D"), order1:=xlAscending, header:=xlYes
　　　　For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
　　　　　　If Not done Then
　　　　　　　　Set wb3 = Workbooks.Open(c.Offset(, 3).Value)
　　　　　　　　done = True
　　　　　　End If
　　　　　　
　　　　　　w = Split(c.Value, "\")
　　　　　　fName = w(UBound(w))
　　　　　　myPath = Left(c.Value, Len(c.Value) - Len(fName))
　　　　　　　　
　　　　　　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
　　　　　　
　　　　　　If c.Offset(, 3).Value <> c.Offset(1, 3).Value Then wb3.Close True
　　　　　　
　　　　Next
　　End With
　　
　　Set wb3 = Nothing
　　
　　Application.ScreenUpdating = True
　　MsgBox "処理が終了しました"
　　
End Sub

4 hits

▼

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