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列のハイパーリンク付文書をE列に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
以下,省略