Excel VBA_2000ハイパーリンク付文書を選択後,各フォルダへ

質問

Excel VBA_2000ハイパーリンク付文書を選択後,各フォルダへ分別振分保存について
(http://okwave.jp/qa/q6003799.html) (http://okwave.jp/qa/q6058720.html)で大変お世話になった者です。Sheets("TEST")E列に1～8の数字あります。これを判断して実行時に，C・D列のハイパーリンク付文書をＥ列に1とあれば1.管理aフォルダに保存，以下，2の時は2.管理bへ保存としたいのです。どのように変更すれば良いでしょうか？どうぞ宜しくお願い致します。
Sub try()
Dim BookUrl As String
Dim BookName As String
Dim n As String
Dim Rng As Range
Dim H As Hyperlink
Dim hLink As String
Dim xName As String
Dim Holdir As String
Dim kk() As String
Dim i As Integer
Dim returnValue As String
ActiveSheet.Unprotect
With Sheets("TEST")
If Not .AutoFilterMode Then Exit Sub
If Not .FilterMode Then
MsgBox "B25のオートフィルタボタンからレ点を選択してください。"
Exit Sub
End If
Set Rng = Intersect(.AutoFilter.Range.EntireRow, .Columns("C:D"))
BookUrl = .Range("D10").Value
n = "_" & .Range("C3").Value
End With
With Sheets("TEST")
ActiveSheet.Shapes("Button 36").Select
On Error Resume Next
MkDir Range("D10") & "7.資料"
MkDir Range("D10") & "7.資料" & "\" & "1.管理a"
MkDir Range("D10") & "7.資料" & "\" & "2.管理b "
MkDir Range("D10") & "7.資料" & "\" & "3.管理c"
MkDir Range("D10") & "7.資料" & "\" & "4.管理d"
MkDir Range("D10") & "7.資料" & "\" & "5.管理e"
MkDir Range("D10") & "7.資料" & "\" & "6.管理f"
MkDir Range("D10") & "7.資料" & "\" & "7.管理g"
MkDir Range("D10") & "7.資料" & "\" & "8.管理h"
On Error GoTo 0
End With
Set Rng = Intersect(Rng, Rng.Offset(1), Rng.SpecialCells(xlCellTypeVisible))
If Rng Is Nothing Then Exit Sub
UserForm1.Show vbModeless
UserForm1.Repaint
'■※1）画面更新停止
Application.ScreenUpdating = False
'rng.HyperlinksをLoop
For Each H In Rng.Hyperlinks
hLink = H.Address
If UCase(Right$(hLink, 3)) = "XLS" Then
xName = Mid$(hLink, InStrRev(hLink, "/") + 1)
ReDim kk(8)
kk(0) = "1.管理a"
kk(1) = "2.管理b"
kk(2) = "3.管理c"
kk(3) = "4.管理d"
kk(4) = "5.管理e"
kk(5) = "6.管理f"
kk(6) = "7.管理g"
kk(7) = "8.管理h"
For i = 0 To 7
Holdir = "7.資料" & "\" & kk(i) & "\"
BookName = BookUrl & Holdir & Replace$( _
xName, ".xls", n & ".xls", , , vbTextCompare)
returnValue = URLDownloadToFile(0,hLink,BookName,0,0)
H.Address = BookName
Next i
End If
以下，省略

この投稿のマルチメディアは削除されているためご覧いただけません。

回答No.1

end-u · ベストアンサー

>Sheets("TEST")E列に1～8の数字あります。
>これを判断して実行時に，C・D列のハイパーリンク付文書を
>Ｅ列に 1とあれば1.管理aフォルダに保存，
>以下，2の時は2.管理bへ保存...

現状のコードではRng.HyperlinksをLoopする時にへんな事になってます。
Loopの度に配列kk()に値をセットするのは無駄でしょう。
さらにFor i = 0 To 7...Next では全部のフォルダに保存されてしまいます。

Rng.HyperlinksをLoopする時、それぞれの h の行の、E列の値を取得して判断すれば良いです。
以下がそのキモの部分。
きちんと理解できれば自分で組み込めるはずです。

Sub test()
　　Dim rng　　　　As Range
　　Dim h　　　　　As Hyperlink
　　Dim Holdir　　 As String
　　Dim kk(1 To 8) As String
　　Dim x

　　kk(1) = "1.管理a"
　　kk(2) = "2.管理b"
　　kk(3) = "3.管理c"
　　kk(4) = "4.管理d"
　　kk(5) = "5.管理e"
　　kk(6) = "6.管理f"
　　kk(7) = "7.管理g"
　　kk(8) = "8.管理h"

　　With Sheets("TEST")
　　　　Set rng = .Columns("C:D")
　　　　Set rng = rng.SpecialCells(xlCellTypeVisible)
　　　　For Each h In rng.Hyperlinks
　　　　　　x = .Range("E" & h.Range.Row).Value
　　　　　　Holdir = "7.資料\" & kk(x) & "\"
　　　　　　Debug.Print x, Holdir
　　　　Next
　　End With

　　Set rng = Nothing
End Sub

お礼

お世話になっております。（毎回）
この度もご回答を有難うございました。m(_　_)m

>全部のフォルダに保存されてしまいます。
それで困っていました。
（配列を使うとこまでは考えてたのですが，難しくて・・・。）
>x = .Range("E" & h.Range.Row).Value
この部分がしたいことでしたが，わかりませんでした。
再度トライしてみます。

来週，締め切りか補足をさせてください。（作成し直しますので。）

どうも有難うございました。

補足

有難うございました。”キモの部分”を参考にさせていただいて
バッチリ！動くようになりました。（＾＾）

作成したいものは前々回，前回とお力添えいただきまして
無事完成していたのですが，
案件として
・8フォルダへの振分保存
・word文書も保存する
ことが追加となり，困っていました。

現在は
下記←行の"XLS"を”DOC”にして，
全体のExcelファイルに対する処理コードを
そのままコピーしてWORDファイルも処理をさせています。
←の部分でExcelファイルとWORDファイルを一括で対象とすることは
可能でしょうか？
（andや＆を使用していろいろ試してはみました。andや＆ではないのでしょうか？）

現在でも動いているので，
また，本スレッドとは直接は関係ないので
ここで質問するのはいけないな。とは思ったのですが，
xlsとdocの同時指定が結局わからないままだったので
できれば知りたいと思いました。
どうぞ，宜しくお願い致します。

If UCase(Right$(hLink, 3)) = "XLS" Then　←
xName = Mid$(hLink, InStrRev(hLink, "/") + 1)
BookName = BookUrl & Holdir & Replace$( _
xName, ".xls", n & ".xls", , , vbTextCompare)
Dim returnValue As String
'URLDownloadToFile API をコールする
returnValue = URLDownloadToFile(0, hLink, BookName, 0, 0)
H.Address = BookName

回答No.2

end-u

And ではなくて Or でしょう。
実際には[Select Case ステートメント]を使うと簡潔にまとめられます。
：
Dim x, chk As String '追加変数
：
For Each h In rng.Hyperlinks
　　hLink = h.Address
　　chk = LCase(Mid$(hLink, InStrRev(hLink, ".")))
　　Select Case chk
　　Case ".xls", ".xlsx", ".doc", ".docx"
　　　　xName = Mid$(hLink, InStrRev(hLink, "\") + 1)
　　　　x = Range("E" & h.Range.Row).Value
　　　　Holdir = "7.資料\" & kk(x) & "\"
　　　　BookName = BookUrl & Holdir & Replace$( _
　　　　　　　　　 xName, chk, n & chk, , , vbTextCompare)
　　　　returnValue = URLDownloadToFile(0, hLink, BookName, 0, 0)
　　　　h.Address = BookName
　　End Select
Next

お礼

お世話になっております。

Select Case ステートメントの例，
有難うございました。
".xlsx", ".docx"のことも
恐らく，考えなくてはいけない状況になるだろうなと
思っていましたので，とても勉強になりました。

この度もお世話になりました。
本当に助かりました。有難うございました。m(_　_)m