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

質問

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

検索が下手なのか，参考となる情報がなかなか見つからなかったため，初めて投稿しました。
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

回答No.3

end-u · ベストアンサー

>かなりの初心者なので原因がわかりませんが，本当に助かりました。
...とりあえず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 様

ご回答有難うございました。
お恥ずかしいです。私事で恐縮ですが，1ヶ月程前に業務で初めてExcel VBAを使って「こういうものを作って欲しい」と言われました。
期間はまだあるため，「すぐに回答欲しいです」マークはつけなかったのですが，提示されたものは私にとっては高度なものでした。
この1ヶ月，勉強と言うよりはいきなり実践で「マクロ起動時実行」，「メッセージboxの表示」，「ネットワークも絡んでいる保存場所指定（これは別ウィンドウ表示で切り抜けました）」，「セル値を参照してファイル名変更保存」などをWEB情報から入手し，”なんとなく加工”をして進めてきました。
なので，ほとんど基本がなっていないと思います。
約半月悩みましたが，今回の問題は自分では解決できなかったため，こちらのサイトで今回初めて投稿しました。

教えていただいた参考サイトで基本を学びながら進めて行きたいと思います。「参考サイトURLの記載」を有難うございました。ｍ(_　_)ｍ

いただいたコードですが，したいこと（複数のハイパーリンク付き文書の保存（ファイル名の変更含む）はバッチリでした。
ただ，B25のオートフィルタボタンをユーザが実行しなかった場合は，
Ｂ列にレ（全角カタカナのレ）が入っていない（Ｃ列，Ｄ列の）ハイパーリンク文書が保存されてしまいました。
「Ｂ列にレがあれば今回の動作させる」としたい時はどうすれば良いのか？で，今，試行錯誤しています。
日々，新しい質問が投稿されているのでこちらのコメントを見ていただけるか心配ですが，ご存知でしたらご教授いただけたら助かります。

回答No.4

end-u

>'AutoFilterModeでなければ抜ける
>If Not .AutoFilterMode Then Exit Sub
この下に
If Not .FilterMode Then Exit Sub
の一行を入れてみてください。
フィルターがかかってなければ実行しないようにします。
#多分。
#しばらくパソコンない環境なので試せません。
#確認してみて下さいね

厳密に処理しようとするなら
B25起点でフィルタがかかってるか、
『レ』が抽出条件か、などチェックしたほうが良いかもしれません。
運用状況次第です。
スキルアップしたらチャレンジしてみてもいいかもしれませんね。

お礼

end-u 様

度々，本当に有難うございます。

>If Not .FilterMode Then Exit Sub
の一行を入れたら実行しないようになりました。
厳密に処理したいため，
>B25起点でフィルタがかかってるか、
>『レ』が抽出条件か、などチェックしたほうが良いかもしれません。
御意見のどちらかできれば最高とは思いましたが，
今の私の力では無理なので
下記部分に以下のメッセージを出すことにしました。
With Sheets("TEST")
'AutoFilterModeでなければ抜ける
If Not .AutoFilterMode Then Exit Sub
If Not .FilterMode Then
MsgBox "B25のオートフィルタボタンを実行してください"
Exit Sub
End If
これでなんとか切り抜けられました。
未熟な私に参考サイトのURLやアドバイスをしていただきまして本当に感謝しております。
end-u様に今回教えていただいたことで最終形の半分まで進むことができました。
納期までまだありますので，今後，基本を学ぶことにも時間を使いたいと思っています。
（このような時間ができたこと事態，すべてend-u様のおかげです。）
本当に御世話になりました。有難うございました。

追伸：後ほど（こちらへの投稿初めてなので）質問締切手続きしたいと思っています。（有難うございました。）

回答No.2

end-u

『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 様

ご回答有難うございました。下記の部分の(2)で行いたいことができました。（助かりました。）
ただ，(1)だとD10で指定した場所へ保存がされませんでした。
かなりの初心者なので原因がわかりませんが，本当に助かりました。

(1)
>Debug.Print BookUrl & Replace$(.Name, ".xls", n & ".xls", , , vbTextCompare)
(2)
>.SaveAs Filename:=BookUrl & Replace$(.Name, ".xls", n & ".xls", , , vbTextCompare)
　　.Close

余談の部分ですが，大変参考になります。
URLDownloadToFile関数調べてみます。
（実際に動かしてみて気が付いたのですが，ファイルを開く動作だと，画面がちらつきます。）
WEB上で情報を入手したので他言語に精通しているわけではないんです・・・。
有難うございました。

もう1つだけ質問しても良いでしょうか？
同じ文書名が抽出され，保存されるとき，
既に文書があります。上書しますか？と出てしまいます。
これをメッセージなしで勝手に上書する動作を入れたいのですが，
LOOPの中で同じファイル名の場合上書すれば解決しますでしょうか？
そのコードのキーワード？，使える関数？，
また，
どの辺りに入れたら良いのか教えていただけないでしょうか？（ファイルのダウンロードの部分？保存の部分？）
教えて頂けると助かります。
（ここまで大変御世話になっているため，ヒントだけで構いませんので。）
どうぞ宜しくお願いします。

回答No.1

end-u

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で既存ファイルがある時の処理など検討しなければいけないと思います。

補足

end-u 様
私の分かり辛い質問の説明に，早速のご回答を有難うございます。
教えていただきましたコード，大変参考になりました。（ダウンロードできています。感動。。。）
説明が不十分だったため，(2)の動作が変わっていました。((1)はご質問の回答になります。)
この点に関してご教示いただいても良いでしょうか？

(1)）
>C:D列に.xls、.htmlへのハイパーリンクがあって、処理したいのはC列のみですか？
C列とＤ列になります。

(2)）
当初のファイル名変更保存の下記コードで必要な部分があります。

教えていただきましたコードで保存すると00-00_ダウンロードした文書名.xlsとなりますが，
ダウンロードした文書名_ C3の値（変数n）.xlsとしたいと思っています。

当初のファイル名変更保存のコード）
Sub Macro6()
Dim BookUrl As String
Dim n As String　　←必要な部分になります
BookUrl = Range("D10").Value
n = Range("C3").Value　←必要な部分になります
Range("C28").Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True　ActiveWorkbook.SaveAs Filename:= _←今回の，複数のハイパーリンク保存コードで動作できるようになりました。有難うございます。ここが一番難しかったので助かりました。m(_　_)m 　
"" & BookUrl & "ダウンロードした文書名" & "_" & n & ".xls"　←ここの部分になります。
ActiveWindow.Close
End Sub

Sub try()
～省略
Dim n As String　←追加してます

With Sheets("sheet1 ")
～省略
If UCase(Right$(h.Address, 3)) = "XLS" Then　←(3)
h.Follow NewWindow:=False
n = Range("C3").Value　←ここに入れましたが間違い？
With ActiveWorkbook
.SaveAs Filename:="" & BookUrl & .Name & "_" & n & ".xls"←.Nameの部分で「.xls」と切り離したいと思っています。どうすればできますでしょうか？(3)部分で切り離しは可能でしょうか？
.Close
End With
End If
～省略
End Sub

申し訳ありません。どうぞ宜しくお願い致します。