ハイパーリンクを開いての繰り返し処理

Question

現在、VBAにてデータ処理の自動化を行っております。
I8～I500までのセルにcsvが開けるハイパーリンクを設定しているのですが そのリンクを開いてcsvを指定フォルダに保存していきたいです。名前は開いたデータと同じ名前のままでいいです。

現在下記のようなVBAを作成したのですがI8にあるリンクのcsvしか保存できませんでした。
選択範囲の中で値がなくなったら処理が終わりというVBAになります。
C5のセルには保存先のアドレスを記載しております。
また、最後にマクロを組んでいるExcelも閉じてしまうので、開いたままにしたいです。

Sub ハイパーリンクを開く()

Dim FolderName As String
Dim FilName As String
Dim i

FolderName = Range("C5").Value
FilName = Range("I8").Value

Application.DisplayAlerts = False
Application.ScreenUpdating = False

If Application.CountA(Range("I8:I500")) > 0 Then

For i = 8 To 500

Workbooks("VBA.xlsm").Worksheets("Sheet1").Cells(i, 9).Select
Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
ActiveWorkbook.SaveAs FileName:=FolderName & "" & FilName
ActiveWorkbook.Close

Next i

End If

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

ご教示ただけると幸いです。

Answer 1

ActiveWorkbook.SaveAs FileName:=FolderName & "\" & FilName

だと FileName は Range("I8").Value 固定なので I8 の名前で上書きされますね。

下記にすれば開いたブック名で保存されます。

ActiveWorkbook.SaveAs FileName:=FolderName & "\" & & ActiveWorkbook.Name

---

ただ、やっていることは、ハイパーリンク先のCSVファイルを C5セルのフォルダーにコピーしているだけなので、わざわざブックを開く必要はないですね。FileCopyステートメントでコピーできますので。

Sub ハイパーリンクファイルをコピー()
    Dim FolderName As String
    Dim i As Long

    With Workbooks("VBA.xlsm").Worksheets("Sheet1")

        FolderName = .Range("C5").Value & "\" 

        If Application.CountA(.Range("I8:I500")) > 0 Then
            For i = 8 To 500
                If .Cells(i, 9).Value <> "" Then
                    FileCopy .Cells(i, 9).Hyperlinks(1).Address,  _
                             FolderName & .Cells(i, 9).Value
                End If
            Next i
        End If
    End With

End Sub

Comments

[FANVGwoS2yVCQha]

ご回答ありがとうございます。
コピーのやり方がわからず
今回のような書き方をしていたので
大変勉強になりました。

Answer 2

・FilNameをRange（”I8”）で取得したまま（全部同じ名前で上書きしていた）なのを、Forループ内で毎回取得しなおす
・ActiveWorkbook.Closeがブックを閉じる命令なので削除

取り敢えずこれで最低限の動きはしてくれるはずです。

Dim FolderName As String
Dim FilName As String
Dim i

FolderName = Range("C5").Value

Application.DisplayAlerts = False
Application.ScreenUpdating = False

If Application.CountA(Range("I8:I500")) > 0 Then

For i = 8 To 500

FilName = Range("I" & i).Value
Workbooks("VBA.xlsm").Worksheets("Sheet1").Cells(i, 9).Select
Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
ActiveWorkbook.SaveAs FileName:=FolderName & "\" & FilName

Next i

End If

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

その他気になったところとして
・マクロが書かれているワークブックを指定するときは、単純にThisWorkbookにした方が良い
・毎回セルをSelectしてSelection.Hyperlinks(1)を指定するのも実行速度やらいろいろな面で旨くないので、慣れたらFor Each inによるハイパーリンクそのもののループができたら良いと思います。

Comments

[FANVGwoS2yVCQha]

ご回答ありがとうございます。
細かいところまで教えていただき
大変勉強になりました。