Dim myRng As Range
Set myRng = ActiveDocument.Range(Start:=3, End:=5) '3～5文字までを範囲選択する
With myRng
.Font.Name = "HG丸ｺﾞｼｯｸM-PRO" 'フォントを「HG丸ｺﾞｼｯｸM-PRO」に変更する
.Font.Color = wdColorBlue '文字を青色にする
.InsertParagraphBefore '選択した範囲の直前を改行する
.InsertParagraphAfter '選択した範囲の直後を改行する
.InsertAfter Text:="実験" '選択した範囲の直後に文字を挿入する
End With
'三～五文字までの文字を範囲選択する
With ActiveDocument.Range(Start:=3, End:=5)
.Text = "てすと" '書き換える
.Delete '削除する
End With
With ActiveDocument.Range(Start:=3, End:=5)
.Text = "てすと" '書き換える
.Delete '削除する
End With
'カーソル位置に文字を入力する
Selection.TypeText Text:="てすと"
'改行
Selection.TypeParagraph
Selection.TypeText Text:="てすと"
'改行
Selection.TypeParagraph
指定したｱﾄﾞﾚｽ内のサブフォルダとファイル名（拡張子は事前に指定すること）を抽出する。
<サンプル>
Const kaku As String = ".txt" '抽出する拡張子
Sub aaaa()
' 指定したフォルダ内のファイルの一覧をシートへ出力する
Const cnsTitle = "フォルダ内のファイル名一覧取得"
Const cnsDIR = "\*.*"
Dim myAPP As Application
Dim myPath As String
Dim myFileName As String
Dim i As Long
Set myAPP = Application
' InputBoxでフォルダ指定を受ける
myPath = myAPP.InputBox("参照するフォルダ名を入力して下さい。", _
cnsTitle, "C:")
' フォルダの存在確認
If Dir(myPath, vbDirectory) = "" Then
MsgBox "指定のフォルダは存在しません。", vbExclamation, cnsTitle
Exit Sub
End If
' 先頭のファイル名の取得
myFileName = Dir(myPath & cnsDIR, vbDirectory)
' サブフォルダが見つからなくなるまで繰り返す
Do While myFileName <> ""
If GetAttr(myPath) And vbDirectory Then
If myFileName <> "." And myFileName <> ".." Then
If InStr(myFileName, kaku) > 0 Then
'-1：指定した拡張子の場合 → ≪ファイル名≫の形式にする
i = i + 1 ' 行を加算
Cells(i, 1).Value = "≪" & myFileName & "≫"
Else
'-2：フォルダの場合 → フルパスを取得
i = i + 1 ' 行を加算
Cells(i, 1).Value = myPath & "\" & myFileName
End If
End If
End If
' 次のファイル名を取得
myFileName = Dir()
Loop
End Sub
<サンプル>
Const kaku As String = ".txt" '抽出する拡張子
Sub aaaa()
' 指定したフォルダ内のファイルの一覧をシートへ出力する
Const cnsTitle = "フォルダ内のファイル名一覧取得"
Const cnsDIR = "\*.*"
Dim myAPP As Application
Dim myPath As String
Dim myFileName As String
Dim i As Long
Set myAPP = Application
' InputBoxでフォルダ指定を受ける
myPath = myAPP.InputBox("参照するフォルダ名を入力して下さい。", _
cnsTitle, "C:")
' フォルダの存在確認
If Dir(myPath, vbDirectory) = "" Then
MsgBox "指定のフォルダは存在しません。", vbExclamation, cnsTitle
Exit Sub
End If
' 先頭のファイル名の取得
myFileName = Dir(myPath & cnsDIR, vbDirectory)
' サブフォルダが見つからなくなるまで繰り返す
Do While myFileName <> ""
If GetAttr(myPath) And vbDirectory Then
If myFileName <> "." And myFileName <> ".." Then
If InStr(myFileName, kaku) > 0 Then
'-1：指定した拡張子の場合 → ≪ファイル名≫の形式にする
i = i + 1 ' 行を加算
Cells(i, 1).Value = "≪" & myFileName & "≫"
Else
'-2：フォルダの場合 → フルパスを取得
i = i + 1 ' 行を加算
Cells(i, 1).Value = myPath & "\" & myFileName
End If
End If
End If
' 次のファイル名を取得
myFileName = Dir()
Loop
End Sub
ｱﾄﾞﾚｽが書かれた表（ここでは （作成例）エクセルの表を元に、フォルダを作成する で用いた物を使用する）の中にあるファイル全てを、
指定したフォルダへ出力する。
なお、ここでは同一名のファイルがある場合は出力日時と連番を記す。
＜サンプル＞
'実行時は深部のディレクトリを指定すること
'！！！場合によってはドライブ全体を抽出することになるので！！！
Const kaku As String = ".txt" '抽出する拡張子
Const goA As String = "A4" 'ディレクトリの最上層が書かれたセル位置
Const InGyo As Long = 4 '処理を始める行
Dim OutFile As Variant '書き込み先のアドレス
Dim FilePath As String '読み込み元のｱﾄﾞﾚｽ
Dim myFile() As String '出力先のファイル名を格納する
Dim myFileNo As Long
Dim myLink() As String '出力したことのあるｱﾄﾞﾚｽを格納する
Dim myLinkNo As Long
Dim myFlag As Boolean 'アドレスを取得しないかどうか 3-2-5に対応
Dim myDay As String
Sub 指定ディレクトリからファイルを取得する()
Dim R As Long, C As Long
Dim i As Long '処理を行っている階層の位置
Dim n As Long '処理を行っているフォルダ
Dim x As Long
ReDim Preserve myLink(0)
'0:出力する際のファイル名
myDay = Year(Date) & Month(Date) & Day(Date) & _
"_" & Hour(Time) & Minute(Time) & Second(Time)
'1：既に出力先となるファイル名があるか調べる
buf2 = Dir(OutFile & "\*" & kaku)
ReDim Preserve myFile(0)
Do While buf2 <> ""
ReDim Preserve myFile(UBound(myFile) + 1) '値を残したまま配列を再設定する
myFile(UBound(myFile)) = buf2
'次のファイル名
buf2 = Dir()
Loop
'2：出力先を指定する
Dim objShell As Object, objFo As Object
Set objShell = CreateObject("Shell.Application")
Set objFo = objShell.BrowseForFolder(0, "出力するフォルダを選択して下さい", &H1, ROOT_FOLDER)
If objFo Is Nothing Then
'キャンセルされたので処理を中止する
Exit Sub
End If
OutFile = objFo.Items.Item.Path
'3：入力先を指定する
R = Range(goA).CurrentRegion.Rows.Count 'ディレクトリの数
C = Range(goA).CurrentRegion.Columns.Count '階層の深さ
'3-1:4行目のディレクトリを取得する
For i = 1 To C
'-1:パスを取得する
If FilePath = "" Then
'一番上の階層（読み込む位置は実質range("A4")
FilePath = Cells(4, i).Value
' ReDim Preserve myLink(0)
' myLink(1) = FilePath
ElseIf Cells(4, i).Value <> "" Then
FilePath = FilePath & "\" & Cells(4, i).Value
End If
'-2:空白の場合はフォルダが存在しない
'→取得するファイルは存在しない
'∴ ループを抜ける
If Dir(FilePath, vbDirectory) = "" Then
Exit For
End If
'-3：出力したことのあるｱﾄﾞﾚｽはmyLinkへ格納する
Call チェックアドレス
If myFlag = True Then
'FilePathは出力したことのアドレスであるを示す
'∴ 処理しない
Else
'-4：取得したフォルダアドレスの中にあるファイルを、
'1で指定したアドレスへコピーする
ReDim Preserve myLink((UBound(myLink) + 1))
myLink(UBound(myLink)) = FilePath '出力したことのアドレスの履歴へ格納する
Call ファイルread
End If
Next i
FilePath = ""
'3-2:5行目以降の処理を行う
For n = 5 To 5 + R
'一旦、FilePathを空白にする
FilePath = ""
'浅い階層から深い階層へアドレスを読み進める
For i = 1 To C
'-1：変数ｘ = FilePathへ代入するｱﾄﾞﾚｽ（列数）
x = n '
If Cells(n, i).Value = "" Then
'空白の場合は上の列を読み込む(最大InGyo-1行目まで）
Do While Cells(x, i).Value = ""
If x = InGyo - 1 Then
'読み込み始めの行InGyoよりも上の行になったら処理を中止する
Exit Do
Else
x = x - 1
End If
Loop
Else
'空白でない場合はその値をFilePathへ
End If
'-2:パスを取得する
If FilePath = "" Then
'一番上の階層（読み込む位置は実質range("A4")
FilePath = Cells(x, i).Value
ElseIf Cells(x, i).Value <> "" Then
FilePath = FilePath & "\" & Cells(x, i).Value
End If
'-3:フォルダが存在するかどうか確認する
If Dir(FilePath, vbDirectory) = "" Then
'空白の場合はフォルダが存在しない
'→取得するファイルは存在しない
'∴ ループを抜ける
Exit For
End If
'-4：出力したことのアドレスか調べる
Call チェックアドレス
If myFlag = True Then
'FilePathは出力したことのアドレスであるを示す
'∴ 処理しない
Else
'-5:ファイル名を取得して、データをコピーする
ReDim Preserve myLink((UBound(myLink) + 1))
myLink(UBound(myLink)) = FilePath '出力したことのアドレスの履歴へ格納する
Call ファイルread
End If
Next i
FilePath = ""
Next n
myFileNo = 0
Set objShell = Nothing
Set objFo = Nothing
MsgBox "処理が完了しました"
End Sub
Private Sub チェックアドレス()
myFlag = False
myLinkNo = 0
Do While UBound(myLink) >= myLinkNo
If myLink(myLinkNo) = FilePath Then
'FilePathは出力したことのアドレスである
'→今回このｱﾄﾞﾚｽのデータは取得しない
'∴ ループを抜ける
myFlag = True
Exit Do
End If
'次のファイル名
myLinkNo = myLinkNo + 1
Loop
End Sub
Private Sub ファイルread()
'ファイル名を確認し、所定の場所にコピーする
Dim buf As String, buf2 As String
Dim NewFileName As String
Dim myC As Boolean
Dim i As Long
'出力元のファイル名を抽出する
buf = Dir(FilePath & "\*" & kaku) '拡張子（変数kaku）が.txtのファイルを抽出する
Do While buf <> ""
'出力先にあるファイル名と一致しているか探す
myC = False
For i = 1 To UBound(myFile)
If myFile(i) = buf Then
myC = True
Exit For
End If
Next i
'ファイルコピー開始
If myC = False Then
'新たなファイル名を出力
'FileCopy ｺﾋﾟｰ元のファイル名,コピー先のファイル名
FileCopy FilePath & "\" & buf, OutFile & "\" & buf
' 既存ファイル名を格納した変数myFileへ格納する
ReDim Preserve myFile(UBound(myFile) + 1) '値を残したまま配列を再設定する
myFile(UBound(myFile)) = buf
Else
'重複するファイル名のため、名称を変更してコピーする
'ファイル名が既に存在する為、新しい名前を作成する（ファイル名_no）
NewFileName = Left(buf, InStr(buf, ".") - 1) '拡張子前までのファイル名
myFileNo = myFileNo + 1
FileCopy _
FilePath & "\" & buf, _
OutFile & "\" & NewFileName & "_" & myDay & "_" & myFileNo & kaku
'既存ファイル名を格納した変数myFileへ格納する
ReDim Preserve myFile(UBound(myFile) + 1) '値を残したまま配列を再設定する
myFile(UBound(myFile)) = NewFileName & "_" & myDay & "_" & myFileNo & kaku
End If
'次のファイル名を取得する
buf = Dir()
Loop
End Sub
指定したフォルダへ出力する。
なお、ここでは同一名のファイルがある場合は出力日時と連番を記す。
＜サンプル＞
'実行時は深部のディレクトリを指定すること
'！！！場合によってはドライブ全体を抽出することになるので！！！
Const kaku As String = ".txt" '抽出する拡張子
Const goA As String = "A4" 'ディレクトリの最上層が書かれたセル位置
Const InGyo As Long = 4 '処理を始める行
Dim OutFile As Variant '書き込み先のアドレス
Dim FilePath As String '読み込み元のｱﾄﾞﾚｽ
Dim myFile() As String '出力先のファイル名を格納する
Dim myFileNo As Long
Dim myLink() As String '出力したことのあるｱﾄﾞﾚｽを格納する
Dim myLinkNo As Long
Dim myFlag As Boolean 'アドレスを取得しないかどうか 3-2-5に対応
Dim myDay As String
Sub 指定ディレクトリからファイルを取得する()
Dim R As Long, C As Long
Dim i As Long '処理を行っている階層の位置
Dim n As Long '処理を行っているフォルダ
Dim x As Long
ReDim Preserve myLink(0)
'0:出力する際のファイル名
myDay = Year(Date) & Month(Date) & Day(Date) & _
"_" & Hour(Time) & Minute(Time) & Second(Time)
'1：既に出力先となるファイル名があるか調べる
buf2 = Dir(OutFile & "\*" & kaku)
ReDim Preserve myFile(0)
Do While buf2 <> ""
ReDim Preserve myFile(UBound(myFile) + 1) '値を残したまま配列を再設定する
myFile(UBound(myFile)) = buf2
'次のファイル名
buf2 = Dir()
Loop
'2：出力先を指定する
Dim objShell As Object, objFo As Object
Set objShell = CreateObject("Shell.Application")
Set objFo = objShell.BrowseForFolder(0, "出力するフォルダを選択して下さい", &H1, ROOT_FOLDER)
If objFo Is Nothing Then
'キャンセルされたので処理を中止する
Exit Sub
End If
OutFile = objFo.Items.Item.Path
'3：入力先を指定する
R = Range(goA).CurrentRegion.Rows.Count 'ディレクトリの数
C = Range(goA).CurrentRegion.Columns.Count '階層の深さ
'3-1:4行目のディレクトリを取得する
For i = 1 To C
'-1:パスを取得する
If FilePath = "" Then
'一番上の階層（読み込む位置は実質range("A4")
FilePath = Cells(4, i).Value
' ReDim Preserve myLink(0)
' myLink(1) = FilePath
ElseIf Cells(4, i).Value <> "" Then
FilePath = FilePath & "\" & Cells(4, i).Value
End If
'-2:空白の場合はフォルダが存在しない
'→取得するファイルは存在しない
'∴ ループを抜ける
If Dir(FilePath, vbDirectory) = "" Then
Exit For
End If
'-3：出力したことのあるｱﾄﾞﾚｽはmyLinkへ格納する
Call チェックアドレス
If myFlag = True Then
'FilePathは出力したことのアドレスであるを示す
'∴ 処理しない
Else
'-4：取得したフォルダアドレスの中にあるファイルを、
'1で指定したアドレスへコピーする
ReDim Preserve myLink((UBound(myLink) + 1))
myLink(UBound(myLink)) = FilePath '出力したことのアドレスの履歴へ格納する
Call ファイルread
End If
Next i
FilePath = ""
'3-2:5行目以降の処理を行う
For n = 5 To 5 + R
'一旦、FilePathを空白にする
FilePath = ""
'浅い階層から深い階層へアドレスを読み進める
For i = 1 To C
'-1：変数ｘ = FilePathへ代入するｱﾄﾞﾚｽ（列数）
x = n '
If Cells(n, i).Value = "" Then
'空白の場合は上の列を読み込む(最大InGyo-1行目まで）
Do While Cells(x, i).Value = ""
If x = InGyo - 1 Then
'読み込み始めの行InGyoよりも上の行になったら処理を中止する
Exit Do
Else
x = x - 1
End If
Loop
Else
'空白でない場合はその値をFilePathへ
End If
'-2:パスを取得する
If FilePath = "" Then
'一番上の階層（読み込む位置は実質range("A4")
FilePath = Cells(x, i).Value
ElseIf Cells(x, i).Value <> "" Then
FilePath = FilePath & "\" & Cells(x, i).Value
End If
'-3:フォルダが存在するかどうか確認する
If Dir(FilePath, vbDirectory) = "" Then
'空白の場合はフォルダが存在しない
'→取得するファイルは存在しない
'∴ ループを抜ける
Exit For
End If
'-4：出力したことのアドレスか調べる
Call チェックアドレス
If myFlag = True Then
'FilePathは出力したことのアドレスであるを示す
'∴ 処理しない
Else
'-5:ファイル名を取得して、データをコピーする
ReDim Preserve myLink((UBound(myLink) + 1))
myLink(UBound(myLink)) = FilePath '出力したことのアドレスの履歴へ格納する
Call ファイルread
End If
Next i
FilePath = ""
Next n
myFileNo = 0
Set objShell = Nothing
Set objFo = Nothing
MsgBox "処理が完了しました"
End Sub
Private Sub チェックアドレス()
myFlag = False
myLinkNo = 0
Do While UBound(myLink) >= myLinkNo
If myLink(myLinkNo) = FilePath Then
'FilePathは出力したことのアドレスである
'→今回このｱﾄﾞﾚｽのデータは取得しない
'∴ ループを抜ける
myFlag = True
Exit Do
End If
'次のファイル名
myLinkNo = myLinkNo + 1
Loop
End Sub
Private Sub ファイルread()
'ファイル名を確認し、所定の場所にコピーする
Dim buf As String, buf2 As String
Dim NewFileName As String
Dim myC As Boolean
Dim i As Long
'出力元のファイル名を抽出する
buf = Dir(FilePath & "\*" & kaku) '拡張子（変数kaku）が.txtのファイルを抽出する
Do While buf <> ""
'出力先にあるファイル名と一致しているか探す
myC = False
For i = 1 To UBound(myFile)
If myFile(i) = buf Then
myC = True
Exit For
End If
Next i
'ファイルコピー開始
If myC = False Then
'新たなファイル名を出力
'FileCopy ｺﾋﾟｰ元のファイル名,コピー先のファイル名
FileCopy FilePath & "\" & buf, OutFile & "\" & buf
' 既存ファイル名を格納した変数myFileへ格納する
ReDim Preserve myFile(UBound(myFile) + 1) '値を残したまま配列を再設定する
myFile(UBound(myFile)) = buf
Else
'重複するファイル名のため、名称を変更してコピーする
'ファイル名が既に存在する為、新しい名前を作成する（ファイル名_no）
NewFileName = Left(buf, InStr(buf, ".") - 1) '拡張子前までのファイル名
myFileNo = myFileNo + 1
FileCopy _
FilePath & "\" & buf, _
OutFile & "\" & NewFileName & "_" & myDay & "_" & myFileNo & kaku
'既存ファイル名を格納した変数myFileへ格納する
ReDim Preserve myFile(UBound(myFile) + 1) '値を残したまま配列を再設定する
myFile(UBound(myFile)) = NewFileName & "_" & myDay & "_" & myFileNo & kaku
End If
'次のファイル名を取得する
buf = Dir()
Loop
End Sub
下図のような表を作成してから次のコードを実行すると、
表のとおりにフォルダの階層を作成する。
＜サンプル＞
Const goA As String = "A4" 'ディレクトリの最上層が書かれたセル位置
Const InGyo As Long = 4 '処理を始める行（二回目以降の処理は五行目から行う）
Sub フォルダ作成()
Dim R As Long, c As Long
Dim FilePath As String
Dim myLink() As String '出力したことのあるｱﾄﾞﾚｽを格納する
ReDim Preserve myLink(0)
Dim myFlag As Boolean 'アドレスを取得しないかどうか
Dim co As Long
Dim i As Long '処理を行っている階層の位置
Dim n As Long '処理を行っているフォルダ
Dim x As Long
'二回目（5行目）以降で使用
'～子ディレクトリがない→ループから抜ける
'1回目のfalse ： 親ディレクトリの空白取得中
'true ： 空白ではない
'2回目のfalse ： 再度空白になった→ループから抜ける
Dim chF As Boolean
R = Range(goA).CurrentRegion.Rows.Count 'ディレクトリの数
c = Range(goA).CurrentRegion.Columns.Count '階層の深さ
'～～～4行目のディレクトリを構築する
For i = 1 To c
'-1-1:パスを取得する
If FilePath = "" Then
'一番上の階層（読み込む位置は実質range("A4")
FilePath = Cells(InGyo, i).Value
ElseIf Cells(InGyo, i).Value <> "" Then
FilePath = FilePath & "\" & Cells(InGyo, i).Value
End If
'-1-2：パスを取得したことのある履歴に保管する
ReDim Preserve myLink((UBound(myLink) + 1))
myLink(UBound(myLink)) = FilePath
'-2:空白の場合はフォルダが存在しない
If Dir(FilePath, vbDirectory) = "" Then
MkDir FilePath 'フォルダを作成する
End If
Next i
'～～～5行目以降の処理を行う
For n = InGyo + 1 To 3 + R
'フラグを初期値にする
chF = False
'一旦、FilePathを空白にする
FilePath = ""
'浅い階層から深い階層へアドレスを読み進める
For i = 1 To c
'-0：変数ｘ = FilePathへ代入するｱﾄﾞﾚｽ（列数）
x = n '
If Cells(n, i).Value = "" Then
'空白の場合・・・
'1：chFがtrue→次の行に移動
If chF = True Then
Exit For
End If
'2:chFがfalse→上の列を読み込む(最大InGyo-1行目まで）
Do While Cells(x, i).Value = ""
If x = InGyo - 1 Then
'読み込み始めの行InGyoよりも上の行になったら処理を中止する
Exit Do
Else
x = x - 1
End If
Loop
ElseIf Cells(n, i).Value <> "" Then
'空白でない場合はその値をFilePathへ
chF = True
End If
'-1:パスを取得する
If FilePath = "" Then
'一番上の階層
FilePath = Cells(x, i).Value
ElseIf Cells(x, i).Value <> "" Then
FilePath = FilePath & "\" & Cells(x, i).Value
End If
'-2:既に取得したことのあるアドレスか確認する
'既に取得したことがある（myFlag = True）→処理しない
myFlag = False
For co = 1 To UBound(myLink)
If myLink(co) = FilePath Then
'FilePathは出力したことのアドレスである
'→今回このｱﾄﾞﾚｽのデータは取得しない
'∴ ループを抜ける
myFlag = True
Exit For
End If
Next co
'myFlag = True→処理しない
If myFlag <> True Then
'-3:FilePathが存在するかどうか調べる
If Dir(FilePath, vbDirectory) = "" Then
'存在しない場合
MkDir FilePath 'フォルダを作成する
End If
End If
Next i
Next n
MsgBox "処理が完了しました"
End Sub
表のとおりにフォルダの階層を作成する。
＜サンプル＞
Const goA As String = "A4" 'ディレクトリの最上層が書かれたセル位置
Const InGyo As Long = 4 '処理を始める行（二回目以降の処理は五行目から行う）
Sub フォルダ作成()
Dim R As Long, c As Long
Dim FilePath As String
Dim myLink() As String '出力したことのあるｱﾄﾞﾚｽを格納する
ReDim Preserve myLink(0)
Dim myFlag As Boolean 'アドレスを取得しないかどうか
Dim co As Long
Dim i As Long '処理を行っている階層の位置
Dim n As Long '処理を行っているフォルダ
Dim x As Long
'二回目（5行目）以降で使用
'～子ディレクトリがない→ループから抜ける
'1回目のfalse ： 親ディレクトリの空白取得中
'true ： 空白ではない
'2回目のfalse ： 再度空白になった→ループから抜ける
Dim chF As Boolean
R = Range(goA).CurrentRegion.Rows.Count 'ディレクトリの数
c = Range(goA).CurrentRegion.Columns.Count '階層の深さ
'～～～4行目のディレクトリを構築する
For i = 1 To c
'-1-1:パスを取得する
If FilePath = "" Then
'一番上の階層（読み込む位置は実質range("A4")
FilePath = Cells(InGyo, i).Value
ElseIf Cells(InGyo, i).Value <> "" Then
FilePath = FilePath & "\" & Cells(InGyo, i).Value
End If
'-1-2：パスを取得したことのある履歴に保管する
ReDim Preserve myLink((UBound(myLink) + 1))
myLink(UBound(myLink)) = FilePath
'-2:空白の場合はフォルダが存在しない
If Dir(FilePath, vbDirectory) = "" Then
MkDir FilePath 'フォルダを作成する
End If
Next i
'～～～5行目以降の処理を行う
For n = InGyo + 1 To 3 + R
'フラグを初期値にする
chF = False
'一旦、FilePathを空白にする
FilePath = ""
'浅い階層から深い階層へアドレスを読み進める
For i = 1 To c
'-0：変数ｘ = FilePathへ代入するｱﾄﾞﾚｽ（列数）
x = n '
If Cells(n, i).Value = "" Then
'空白の場合・・・
'1：chFがtrue→次の行に移動
If chF = True Then
Exit For
End If
'2:chFがfalse→上の列を読み込む(最大InGyo-1行目まで）
Do While Cells(x, i).Value = ""
If x = InGyo - 1 Then
'読み込み始めの行InGyoよりも上の行になったら処理を中止する
Exit Do
Else
x = x - 1
End If
Loop
ElseIf Cells(n, i).Value <> "" Then
'空白でない場合はその値をFilePathへ
chF = True
End If
'-1:パスを取得する
If FilePath = "" Then
'一番上の階層
FilePath = Cells(x, i).Value
ElseIf Cells(x, i).Value <> "" Then
FilePath = FilePath & "\" & Cells(x, i).Value
End If
'-2:既に取得したことのあるアドレスか確認する
'既に取得したことがある（myFlag = True）→処理しない
myFlag = False
For co = 1 To UBound(myLink)
If myLink(co) = FilePath Then
'FilePathは出力したことのアドレスである
'→今回このｱﾄﾞﾚｽのデータは取得しない
'∴ ループを抜ける
myFlag = True
Exit For
End If
Next co
'myFlag = True→処理しない
If myFlag <> True Then
'-3:FilePathが存在するかどうか調べる
If Dir(FilePath, vbDirectory) = "" Then
'存在しない場合
MkDir FilePath 'フォルダを作成する
End If
End If
Next i
Next n
MsgBox "処理が完了しました"
End Sub
Sleepを使ってSendKeysを送るタイミングをはかる。
'Sleepに関する宣言
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
’Sleepを使用する
Sleep 1000 ’1秒停止
'Sleepに関する宣言
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
’Sleepを使用する
Sleep 1000 ’1秒停止
innerTextの文言から判別し、
クリックによりリンクへ飛ぶ方法。
＜サンプル＞
Dim objIE As InternetExplorer
Sub リンクへ飛ぶ()
'1:IEを起動する
Set objIE = CreateObject("InternetExplorer.Application")
objIE.Visible = True '見えるようにする
objIE.navigate "http://www.forest.impress.co.jp/library/software/pluslhaca/" 'URLを適宜入力する
Do While objIE.Busy Or objIE.readyState < READYSTATE_COMPLETE
DoEvents
Loop
'2:リンクを取得する
For Each obj In objIE.document.getElementsByTagName("a") 'A herfタグを見つける
If obj.innerText = "ダウンロード" Then
'ﾀﾞｳﾝﾛｰﾄﾞと表示されているリンクをクリックする
obj.Click
Exit For 'ループから抜ける
End If
Next
End Sub
クリックによりリンクへ飛ぶ方法。
＜サンプル＞
Dim objIE As InternetExplorer
Sub リンクへ飛ぶ()
'1:IEを起動する
Set objIE = CreateObject("InternetExplorer.Application")
objIE.Visible = True '見えるようにする
objIE.navigate "http://www.forest.impress.co.jp/library/software/pluslhaca/" 'URLを適宜入力する
Do While objIE.Busy Or objIE.readyState < READYSTATE_COMPLETE
DoEvents
Loop
'2:リンクを取得する
For Each obj In objIE.document.getElementsByTagName("a") 'A herfタグを見つける
If obj.innerText = "ダウンロード" Then
'ﾀﾞｳﾝﾛｰﾄﾞと表示されているリンクをクリックする
obj.Click
Exit For 'ループから抜ける
End If
Next
End Sub
ＨＰからリンク先を取得し移動する。
対象のＨＰの構造上でリンク先を取得して常に8個目に、
表示させたいＵＲＬがあるとした場合の処理方法。
なお、リンク先の取得に ～.Links.Length を用いている。
＜サンプル＞
'↓↓↓↓↓ここから↓↓↓↓↓
Dim objIE As InternetExplorer
Dim HTMLDoc As HTMLDocument
Set HTMLDoc = objIE.document
Dim a As HTMLAnchorElement 'リンク先（a herf）に対応する
Sub リンクへ飛ぶ()
'あらかじめIEでホームページを開いておく
'1:IEを起動する
Set objIE = IE取得開始("+Lhaca - 窓の杜ライブラリ") '開いているHPのタイトルを指定
objIE.Visible = True '見えるないようにする→バックグラウンドで実行する
Call 画面移動が完了するのを待つ
'2:リンクを取得する
On Error Resume Next
For i = 1 To HTMLDoc.Links.Length '～.Links.Lengthはリンク先（a herf）の数を取得している
If i = 8 Then '8個目のリンク先を取得する
Set a = HTMLDoc.Links(i - 1) 'リンク先のＵＲＬを取得
objIE.navigate a
objIE.Visible = True
exit for
End If
Next
On Error GoTo 0
Call 画面移動が完了するのを待つ
End Sub
Private Sub 画面移動が完了するのを待つ()
'EADYSTATEがCOMPLETEになるまで待つ
Do While objIE.Busy Or objIE.readyState < READYSTATE_COMPLETE
DoEvents
Loop
End Sub
'↑↑↑↑↑↑ここまで↑↑↑↑↑↑
対象のＨＰの構造上でリンク先を取得して常に8個目に、
表示させたいＵＲＬがあるとした場合の処理方法。
なお、リンク先の取得に ～.Links.Length を用いている。
＜サンプル＞
'↓↓↓↓↓ここから↓↓↓↓↓
Dim objIE As InternetExplorer
Dim HTMLDoc As HTMLDocument
Set HTMLDoc = objIE.document
Dim a As HTMLAnchorElement 'リンク先（a herf）に対応する
Sub リンクへ飛ぶ()
'あらかじめIEでホームページを開いておく
'1:IEを起動する
Set objIE = IE取得開始("+Lhaca - 窓の杜ライブラリ") '開いているHPのタイトルを指定
objIE.Visible = True '見えるないようにする→バックグラウンドで実行する
Call 画面移動が完了するのを待つ
'2:リンクを取得する
On Error Resume Next
For i = 1 To HTMLDoc.Links.Length '～.Links.Lengthはリンク先（a herf）の数を取得している
If i = 8 Then '8個目のリンク先を取得する
Set a = HTMLDoc.Links(i - 1) 'リンク先のＵＲＬを取得
objIE.navigate a
objIE.Visible = True
exit for
End If
Next
On Error GoTo 0
Call 画面移動が完了するのを待つ
End Sub
Private Sub 画面移動が完了するのを待つ()
'EADYSTATEがCOMPLETEになるまで待つ
Do While objIE.Busy Or objIE.readyState < READYSTATE_COMPLETE
DoEvents
Loop
End Sub
'↑↑↑↑↑↑ここまで↑↑↑↑↑↑
ＩＥのプルダウンを選択するには
.selectedIndex = でインデックス番号を指定する。
なお、インデックス番号は0からはじまる。
＜サンプル＞
Dim objIE As InternetExplorer
Set objIE = CreateObject("InternetExplorer.Application")
objIE.Visible = True '見えるようにする
objIE.navigate "http://saru-html.pupu.jp/8_8.shtml" 'リストボックスとコンボボックスが表示されたHPを開く
'1:IEを起動する
Do While objIE.Busy Or objIE.readyState < READYSTATE_COMPLETE
DoEvents
Loop
'2:入力開始
Dim htdoc As HTMLDocument
Set htdoc = objIE.document
'name属性[kamoku1]を探す
Dim myHTML1 As HTMLAnchorElement
'[デートスポット]リストボックスの[鳥取県]を選択する
For Each myHTML1 In htdoc.getElementsByTagName("SELECT") '[SELECT]タグを用いた場合
If InStr(myHTML1.innerText, "部長") > 0 Then 'myHTML1に部長が含まれるかか調べる
myHTML1.selectedIndex = 1 '部長（インデックス番号1）を選択する
Exit For 'ループから抜ける
End If
Next
.selectedIndex = でインデックス番号を指定する。
なお、インデックス番号は0からはじまる。
＜サンプル＞
Dim objIE As InternetExplorer
Set objIE = CreateObject("InternetExplorer.Application")
objIE.Visible = True '見えるようにする
objIE.navigate "http://saru-html.pupu.jp/8_8.shtml" 'リストボックスとコンボボックスが表示されたHPを開く
'1:IEを起動する
Do While objIE.Busy Or objIE.readyState < READYSTATE_COMPLETE
DoEvents
Loop
'2:入力開始
Dim htdoc As HTMLDocument
Set htdoc = objIE.document
'name属性[kamoku1]を探す
Dim myHTML1 As HTMLAnchorElement
'[デートスポット]リストボックスの[鳥取県]を選択する
For Each myHTML1 In htdoc.getElementsByTagName("SELECT") '[SELECT]タグを用いた場合
If InStr(myHTML1.innerText, "部長") > 0 Then 'myHTML1に部長が含まれるかか調べる
myHTML1.selectedIndex = 1 '部長（インデックス番号1）を選択する
Exit For 'ループから抜ける
End If
Next