Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

3645 / 13644 ﾂﾘｰ

←次へ　｜　前へ→

▼

【60963】コードの纏め みね 09/3/27(金) 17:10

【60966】Re:コードの纏め n 09/3/27(金) 23:00


	【60963】コードの纏め

みね - 09/3/27(金) 17:10 -


	引用なし

	パスワード

前任者からもらったファイルなのですが
下記のように同じ作業を繰り返す長い状態にあります
これをうまく纏める方法を教えていただけませんでしょうか
　　Const cnsTITLE = "フォルダ内のファイル名一覧取得"
　　Const cnsDIR = "\*.*"
　　Dim xlAPP As Application
　　Dim strFILENAME1, strFILENAME2, strFILENAME3, strFILENAME4, strFILENAME5, strFILENAME6, strFILENAME7, strFILENAME8, strFILENAME9, strFILENAME10, strFILENAME11, strFILENAME12 As String
　　Dim GYO1, GYO2, GYO3, GYO4, GYO5, GYO6, GYO7, GYO8, GYO9, GYO10, GYO11, GYO12 As Long
　　
　　Set xlAPP = Application
　　' InputBoxでﾌｫﾙﾀﾞ指定を受ける
　　If StrConv(Dir1, vbUpperCase) = "FALSE" Then Exit Sub
　　' ﾌｫﾙﾀﾞの存在確認
　　If Dir(Dir1, vbDirectory) = "" Then
　　　　MsgBox "指定のフォルダは存在しません。", vbExclamation, cnsTITLE
　　　　Exit Sub
　　End If
　　' 先頭のﾌｧｲﾙ名の取得
　　strFILENAME1 = Dir(Dir1 & cnsDIR, vbNormal)
　　' ﾌｧｲﾙが見つからなくなるまで繰り返す
　　Do While strFILENAME1 <> ""
　　　　' 行を加算
　　　　GYO1 = GYO1 + 1　　　 ' 先頭は1行目
　　　　Cells(GYO1, "AP").Value = strFILENAME1
　　　　' 次のﾌｧｲﾙ名を取得
　　　　strFILENAME1 = Dir()
　　Loop
　　
　　' 先頭のﾌｧｲﾙ名の取得
　　strFILENAME2 = Dir(Dir2 & cnsDIR, vbNormal)
　　' ﾌｧｲﾙが見つからなくなるまで繰り返す
　　Do While strFILENAME2 <> ""
　　　　' 行を加算
　　　　GYO2 = GYO2 + 1　　　 ' 先頭は1行目
　　　　Cells(GYO2, "AQ").Value = strFILENAME2
　　　　' 次のﾌｧｲﾙ名を取得
　　　　strFILENAME2 = Dir()
　　Loop
　　
　　' 先頭のﾌｧｲﾙ名の取得
　　strFILENAME3 = Dir(Dir3 & cnsDIR, vbNormal)
　　' ﾌｧｲﾙが見つからなくなるまで繰り返す
　　Do While strFILENAME3 <> ""
　　　　' 行を加算
　　　　GYO3 = GYO3 + 1　　　 ' 先頭は1行目
　　　　Cells(GYO3, "AR").Value = strFILENAME3
　　　　' 次のﾌｧｲﾙ名を取得
　　　　strFILENAME3 = Dir()
　　Loop
　　
　　' 先頭のﾌｧｲﾙ名の取得
　　strFILENAME4 = Dir(Dir4 & cnsDIR, vbNormal)
　　' ﾌｧｲﾙが見つからなくなるまで繰り返す
　　Do While strFILENAME4 <> ""
　　　　' 行を加算
　　　　GYO4 = GYO4 + 1　　　 ' 先頭は1行目
　　　　Cells(GYO4, "AS").Value = strFILENAME4
　　　　' 次のﾌｧｲﾙ名を取得
　　　　strFILENAME4 = Dir()
　　Loop
　　
　　' 先頭のﾌｧｲﾙ名の取得
　　strFILENAME5 = Dir(Dir5 & cnsDIR, vbNormal)
　　' ﾌｧｲﾙが見つからなくなるまで繰り返す
　　Do While strFILENAME5 <> ""
　　　　' 行を加算
　　　　GYO5 = GYO5 + 1　　　 ' 先頭は1行目
　　　　Cells(GYO5, "AT").Value = strFILENAME5
　　　　' 次のﾌｧｲﾙ名を取得
　　　　strFILENAME5 = Dir()
　　Loop
　　
　　' 先頭のﾌｧｲﾙ名の取得
　　strFILENAME6 = Dir(Dir6 & cnsDIR, vbNormal)
　　' ﾌｧｲﾙが見つからなくなるまで繰り返す
　　Do While strFILENAME6 <> ""
　　　　' 行を加算
　　　　GYO6 = GYO6 + 1　　　 ' 先頭は1行目
　　　　Cells(GYO6, "AU").Value = strFILENAME6
　　　　' 次のﾌｧｲﾙ名を取得
　　　　strFILENAME6 = Dir()
　　Loop
　　
　　' 先頭のﾌｧｲﾙ名の取得
　　strFILENAME7 = Dir(Dir7 & cnsDIR, vbNormal)
　　' ﾌｧｲﾙが見つからなくなるまで繰り返す
　　Do While strFILENAME7 <> ""
　　　　' 行を加算
　　　　GYO7 = GYO7 + 1　　　 ' 先頭は1行目
　　　　Cells(GYO7, "AV").Value = strFILENAME7
　　　　' 次のﾌｧｲﾙ名を取得
　　　　strFILENAME7 = Dir()
　　Loop
　　
　　' 先頭のﾌｧｲﾙ名の取得
　　strFILENAME8 = Dir(Dir8 & cnsDIR, vbNormal)
　　' ﾌｧｲﾙが見つからなくなるまで繰り返す
　　Do While strFILENAME8 <> ""
　　　　' 行を加算
　　　　GYO8 = GYO8 + 1　　　 ' 先頭は1行目
　　　　Cells(GYO8, "AW").Value = strFILENAME8
　　　　' 次のﾌｧｲﾙ名を取得
　　　　strFILENAME8 = Dir()
　　Loop
　　
　　' 先頭のﾌｧｲﾙ名の取得
　　strFILENAME9 = Dir(Dir9 & cnsDIR, vbNormal)
　　' ﾌｧｲﾙが見つからなくなるまで繰り返す
　　Do While strFILENAME9 <> ""
　　　　' 行を加算
　　　　GYO9 = GYO9 + 1　　　 ' 先頭は1行目
　　　　Cells(GYO1, "AX").Value = strFILENAME9
　　　　' 次のﾌｧｲﾙ名を取得
　　　　strFILENAME9 = Dir()
　　Loop
　　
　　' 先頭のﾌｧｲﾙ名の取得
　　strFILENAME10 = Dir(Dir10 & cnsDIR, vbNormal)
　　' ﾌｧｲﾙが見つからなくなるまで繰り返す
　　Do While strFILENAME10 <> ""
　　　　' 行を加算
　　　　GYO10 = GYO10 + 1　　　 ' 先頭は1行目
　　　　Cells(GYO1, "AY").Value = strFILENAME10
　　　　' 次のﾌｧｲﾙ名を取得
　　　　strFILENAME10 = Dir()
　　Loop
　　
　　' 先頭のﾌｧｲﾙ名の取得
　　strFILENAME11 = Dir(Dir11 & cnsDIR, vbNormal)
　　' ﾌｧｲﾙが見つからなくなるまで繰り返す
　　Do While strFILENAME11 <> ""
　　　　' 行を加算
　　　　GYO11 = GYO11 + 1　　　 ' 先頭は1行目
　　　　Cells(GYO11, "AZ").Value = strFILENAME11
　　　　' 次のﾌｧｲﾙ名を取得
　　　　strFILENAME11 = Dir()
　　Loop
　　' 先頭のﾌｧｲﾙ名の取得
　　strFILENAME12 = Dir(Dir12 & cnsDIR, vbNormal)
　　' ﾌｧｲﾙが見つからなくなるまで繰り返す
　　Do While strFILENAME12 <> ""
　　　　' 行を加算
　　　　GYO12 = GYO12 + 1　　　 ' 先頭は1行目
　　　　Cells(GYO12, "BA").Value = strFILENAME12
　　　　' 次のﾌｧｲﾙ名を取得
　　　　strFILENAME12 = Dir()
　　Loop
　　Columns("AP").Sort Key1:=Range("AP1") 'AG行をソートします
　　FI1 = Worksheets("test").Cells(1, "AP").End(xlDown)
　　Columns("AQ").Sort Key1:=Range("AQ1") 'AG行をソートします
　　FI2 = Worksheets("test").Cells(1, "AQ").End(xlDown)
　　Columns("AR").Sort Key1:=Range("AR1") 'AG行をソートします
　　FI3 = Worksheets("test").Cells(1, "AR").End(xlDown)
　　Columns("AS").Sort Key1:=Range("AS1") 'AG行をソートします
　　FI4 = Worksheets("test").Cells(1, "AS").End(xlDown)
　　Columns("AT").Sort Key1:=Range("AT1") 'AG行をソートします
　　FI5 = Worksheets("test").Cells(1, "AT").End(xlDown)
　　Columns("AU").Sort Key1:=Range("AU1") 'AG行をソートします
　　FI6 = Worksheets("test").Cells(1, "AU").End(xlDown)
　　Columns("AV").Sort Key1:=Range("AV1") 'AG行をソートします
　　FI7 = Worksheets("test").Cells(1, "AV").End(xlDown)
　　Columns("AW").Sort Key1:=Range("AW1") 'AG行をソートします
　　FI8 = Worksheets("test").Cells(1, "AW").End(xlDown)
　　Columns("AX").Sort Key1:=Range("AX1") 'AG行をソートします
　　FI9 = Worksheets("test").Cells(1, "AX").End(xlDown)
　　Columns("AY").Sort Key1:=Range("AY1") 'AG行をソートします
　　FI10 = Worksheets("test").Cells(1, "AY").End(xlDown)
　　Columns("AZ").Sort Key1:=Range("AZ1") 'AG行をソートします
　　FI11 = Worksheets("test").Cells(1, "AZ").End(xlDown)
　　Columns("BA").Sort Key1:=Range("BA1") 'AG行をソートします
　　FI12 = Worksheets("test").Cells(1, "BA").End(xlDown)
ファイル無:


	【60966】Re:コードの纏め

n - 09/3/27(金) 23:00 -


	引用なし

	パスワード

同様な処理の繰り返しなら、Loop処理でまとめてしまえば良いです。それに、Dir1～Dir12 はどうやって指定しますか？ InputBoxでそれぞれ指定するくらいなら、作業用セルにフォルダ名を入力しておいて、その範囲をLoopしてあげれば良いでしょう。下記はA1:A12のセル範囲にフォルダ名が入力してあるとします。 Sub test() 　　Const cnsDIR = "\*.*" 　　Dim strFILENAME As String 　　Dim GYO As Long 　　Dim r　 As Range 　　Dim v 　　　　Application.ScreenUpdating = False 　　Set r = Range("AP1") 　　For Each v In Range("A1:A12").Value 　　　　If Not IsEmpty(v) Then 　　　　　　If Dir(v, vbDirectory) = "" Then 　　　　　　　　r.Value = "指定のフォルダは存在しません。" 　　　　　　Else 　　　　　　　　strFILENAME = Dir(v & cnsDIR, vbNormal) 　　　　　　　　GYO = 0 　　　　　　　　Do While strFILENAME <> "" 　　　　　　　　　　r.Offset(GYO).Value = strFILENAME 　　　　　　　　　　GYO = GYO + 1 　　　　　　　　　　strFILENAME = Dir() 　　　　　　　　Loop 　　　　　　End If 　　　　　　If GYO > 1 Then r.Resize(GYO).Sort Key1:=r 　　　　End If 　　　　Set r = r.Offset(, 1) 　　Next 　　Set r = Nothing 　　Application.ScreenUpdating = True End Sub 　


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

3645 / 13644 ﾂﾘｰ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free