EXCEL VBA複数のハイパーリンク付き文書を保存について

Question

検索が下手なのか，参考となる情報がなかなか見つからなかったため，初めて投稿しました。
EXCEL VBAは超初心者です。Verは2000になります。どうぞ，宜しくお願いします。
下記のような動作はできますでしょうか？（超初心者のため，できるのかどうかも分かりません。）

データの状態は，TESTというファイル名でSheet1のみ使用しており，1行目～24行目は操作上のセル参照などや操作説明文に使用しています。
B25にオートフィルタ▼マークがあり，以下B26からB300ぐらいまで「レ」が入っています。(これは今後増えていきます。）また，C列D列はハイパーリンク付き文書（**.xlsと**.html）があります。
（ユーザにＣ列Ｄ列を見て必要ない文書はＢ列の「レ」を削除後，B25のオートフィルタ▼を実行してもらう。この後の動作をVBAで行いたいと思っています。）

行いたいこと）
(1)選ばれたＣ列Ｄ列のハイパーリンク付き文書（全て）をD10で指定された場所へ保存する
　補足）Ｄ10はユーザによって指定する場所が違う。（マイドキュメントとは限らない。）

Sub Macro5()
    Dim sPath As String
    Dim hwnd As Long
    Dim iRet As Long
    hwnd = FindWindow("XLMAIN", vbNullString)
    iRet = GetFolderName(hwnd, "フォルダを選択してください。", sPath)
    If iRet = 0 Then
        If Len(sPath) > 3 Then sPath = sPath & "\"
        Cells(10, 4).Value = sPath
    ElseIf iRet = 1 Then
        MsgBox "キャンセルされました。"
    Else
        MsgBox "エラーが発生しました。"
    End If
End Sub

Web上で調べた上記コードを引用させていただいて，ユーザごとに希望保存場所が違うため，別ウィンドウからユーザに保存場所を指定してもらい，D10の値を参照するようにしました。

(2)(1)の時ファイル名を一部変更し保存する。（http://AAA.co.jp/BB/CC/DD/EE/○○－○○.xls　→　D10の値参照\○○－○○_C3の値参照.xls）○○－○○の部分を選ぶようにしたい。
補足）ファイル名は同じではない。

Sub Macro6()
  Dim BookUrl As String
  Dim BookName As String
    BookUrl = Range("D10").Value
    BookName = Range("C3").Value
    Range("C28").Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True←ここの部分がハイパーリンクと関係ありなのでわからない。（ユーザにより選ばれる文書数が違いので）
    ActiveWorkbook.SaveAs Filename:= _
    "" & BookUrl & "00-00" & "_" & BookName & ".xls" ←ここの「00-00」の部分がハイパーリンクと関係ありなのでわからない。（各階層各文書名が違うので）
    ActiveWindow.Close
End Sub

分からないこと）
ユーザによって選ばれる文書（抽出結果）が違うため，Ｂ列でレが選ばれた場合Ｃ列Ｄ列を見る。→その文書をD10セルで指定されている場所へ保存としたいが，Ｃ列Ｄ列の文書にハイパーリンクが貼ってあり，その階層もファイル名も行ごとに違うのでどうしたらいいかわからない。現在，1文書ならば行もファイル名も指定できるのでマクロの実行で保存し，上記コードでD10セルに指定されている場所へ保存できている。

分からないこと）をまとめると，
「ユーザごとに選ばれるハイパーリンク付き文書が違うが，これをD10で指定した場所へ保存したい」
「選ばれたハイパーリンク付き文書のハイパーリングからファイル名を変更して保存する際，「○○－○○」.xls部分のみ引用したい。この部分のみまだクリアーしていません。どうもハイパーリンクが絡むと分からなくなってしまいます。

質問の書き方も長々となってしまい，分かり辛いと思います。すみません。
どうぞ宜しくお願い致します。m(_　_)m

end-u · Accepted Answer

>かなりの初心者なので原因がわかりませんが，本当に助かりました。
...とりあえずURLDownloadToFile関数の事は忘れてください。
VBE（VisualBaicEditor）画面で[Ctrl]+[g]キー同時押しで
[イミディエイト]ウィンドウが出ます。
Debug.Print というのは、
デバッグの為にイミディエイトウィンドウにデータを出力するメソッドです。
イミディエイトウィンドウに出力された文字列を確認してみてほしい
という意味が込められていました。
SaveAsメソッドは ' でコメントアウトしていましたので当然、実行されません。

■※1）画面がちらつくのはApplication.ScreenUpdatingプロパティで制御可能です。

■※2）既存ファイルを無視するならDir関数で存在を調べて、
あればKillステートメントで削除しておけば良いです。

Sub try_2()
　　Dim BookUrl　As String
　　Dim BookName As String
　　Dim n　　　　As String
　　Dim rng　　　As Range
　　Dim h　　　　As Hyperlink

With Sheets("sheet1")
　　　　'AutoFilterModeでなければ抜ける
　　　　If Not .AutoFilterMode Then Exit Sub
　　　　'とりあえずAutoFilter.RangeのC:D列をセット
　　　　Set rng = Intersect(.AutoFilter.Range.EntireRow, .Columns("C:D"))
　　　　BookUrl = .Range("D10").Value
　　　　n = "_" & .Range("C3").Value
　　End With
　　'rngの可視セル（抽出セル）をセット
　　Set rng = Intersect(rng, rng.Offset(1), rng.SpecialCells(xlCellTypeVisible))
　　'抽出なければ抜ける
　　If rng Is Nothing Then Exit Sub

'■※1）画面更新停止
　　Application.ScreenUpdating = False
　　'rng.HyperlinksをLoop
　　For Each h In rng.Hyperlinks
　　　　'Excelファイルの処理
　　　　If UCase(Right$(h.Address, 3)) = "XLS" Then
　　　　　　h.Follow NewWindow:=False
　　　　　　With ActiveWorkbook
　　　　　　　　BookName = BookUrl & Replace$(.Name, ".xls", n & ".xls", , , vbTextCompare)
　　　　　　　　'■※2）既存ファイルあれば削除しておく
　　　　　　　　If Len(Dir(BookName)) > 0 Then Kill BookName
　　　　　　　　.SaveAs Filename:=BookName
　　　　　　　　.Close
　　　　　　End With
　　　　End If
　　Next
　　'■※1）画面更新再開
　　Application.ScreenUpdating = True

Set rng = Nothing
End Sub

もう少し、基礎も押さえておいたほうがよろしいかと思いますので
参考サイトを挙げておきます。
http://excelvba.pc-users.net/
http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/index.html
http://www.asahi-net.or.jp/~ef2o-inue/top01.html
では。
がんばってください。

end-u · Answer

>'AutoFilterModeでなければ抜ける
>If Not .AutoFilterMode Then Exit Sub
この下に
If Not .FilterMode Then Exit Sub
の一行を入れてみてください。
フィルターがかかってなければ実行しないようにします。
#多分。
#しばらくパソコンない環境なので試せません。
#確認してみて下さいね

厳密に処理しようとするなら
B25起点でフィルタがかかってるか、
『レ』が抽出条件か、などチェックしたほうが良いかもしれません。
運用状況次第です。
スキルアップしたらチャレンジしてみてもいいかもしれませんね。

end-u · Answer

『BookUrl & "ダウンロードした文書名" & "_" & n & ".xls"』の場合、

変数nにC3セルの値を入れる時、
Loop内で値は変わらないのでLoop外で１回設定すれば良いです。
その時 "_" も繋げてしまいましょう。

With Sheets("sheet1")
　　':
　　BookUrl = .Range("D10").Value
　　n = "_" & .Range("C3").Value
End With

>切り離しは可能でしょうか？
切り離しも可能ですし、置換しても良いかと思います。

With ActiveWorkbook
　　Debug.Print BookUrl & Left$(.Name, Len(.Name) - 4) & n & ".xls"
　　Debug.Print BookUrl & Replace$(.Name, ".xls", n & ".xls", , , vbTextCompare)
　　'.SaveAs Filename:=BookUrl & Replace$(.Name, ".xls", n & ".xls", , , vbTextCompare)
　　.Close
End With

以下余談です。
FindWindow/GetFolderName等のWindowsAPI関数を使われてますが、
URLDownloadToFile関数を使えばファイルを開かなくてもダウンロードできます。
調べて、応用できるようであれば試してみてください。
ただ、WindowsAPIを扱うなら、基礎はしっかりと押さえておいたほうが良いと思いますよ。
#EXCEL VBAは超初心者でも他言語に精通されてるなら心配しないですけど。

end-u · Answer

C:D列に.xls、.htmlへのハイパーリンクがあって、処理したいのはC列のみですか？
htmlファイルの場合はExcelで開くわけじゃないから別処理になります。
とりあえずxlsファイルに限定するなら以下のような感じになるかと。

Sub try()
　　Dim BookUrl As String
　　Dim rng　　 As Range
　　Dim h　　　 As Hyperlink

With Sheets("sheet1")
　　　　'AutoFilterModeでなければ抜ける
　　　　If Not .AutoFilterMode Then Exit Sub
　　　　'とりあえずAutoFilter行のC:D列をセット
　　　　Set rng = Intersect(.AutoFilter.Range.EntireRow, .Columns("C:D"))
　　　　BookUrl = .Range("D10").Value
　　End With
　　'rngの可視セル（抽出セル）をセット
　　Set rng = Intersect(rng, rng.Offset(1), rng.SpecialCells(xlCellTypeVisible))
　　'抽出なければ抜ける
　　If rng Is Nothing Then Exit Sub
　　'rng.HyperlinksをLoop
　　For Each h In rng.Hyperlinks
　　　　'Excelファイルの処理
　　　　If UCase(Right$(h.Address, 3)) = "XLS" Then
　　　　　　h.Follow NewWindow:=False
　　　　　　With ActiveWorkbook
　　　　　　　　.SaveAs Filename:="" & BookUrl & "00-00" & "_" & .Name
　　　　　　　　.Close
　　　　　　End With
　　　　End If
　　Next
　　
　　Set rng = Nothing
End Sub

rng内のHyperlinkをLoopしてリンクxlsを開いたら、
BookNameはActiveWorkbook.Nameで取れますからそれを使えば良いです。
他に、SaveAsで既存ファイルがある時の処理など検討しなければいけないと思います。

EXCEL VBA複数のハイパーリンク付き文書を保存について

>かなりの初心者なので原因がわかりませんが，本当に助かりました。

>'AutoFilterModeでなければ抜ける

『BookUrl & "ダウンロードした文書名" & "_" & n & ".xls"』の場合、

C:D列に.xls、.htmlへのハイパーリンクがあって、処理したいのはC列のみですか？

この回答への補足

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング