一致したファイル名を先頭に抽出させる方法

質問

Sub Sample()
sPath = "C:\Users\Owner\Downloads\base\setting_000002016\"
nRow = 2
sSubFol = Cells(nRow, 1).Text
Do While sSubFol <> ""
nCol = 11
sFileName = Dir(sPath & sSubFol & "\*.jpg")
Do While sFileName <> ""
Cells(nRow, nCol) = sFileName
sFileName = Dir()
nCol = nCol + 1
Loop
nRow = nRow + 1
sSubFol = Cells(nRow, 1).Text
Loop
End Sub

こちらは、指定の商品番号と同じ商品番号の名前になっているサブフォルダ名のファイル名をK列以降に抽出するというvbaでつくられたプログラムです。

実際の例で説明いたします。
商品番号が１２３、サブフォルダ名１２３だとして、
ファイル名が001.jpg,002.jpg.003.jpg,123.jpgという不規則なファイル名があったとします。

上記のプログラムはファイル名の順番問わず
K列から順番に001.jpg,002.jpg.003.jpg,123.jpgに抽出されるようになっております。

しかし、仮名のファイルですが、123.jpgというファイル名が最初の列に抽出されたほうがこちらとしましても都合がいいので、同じ名前のファイルがあったら先頭に抽出できるようにしたいのですがどのようにしたらよろしいでしょうか？

回答No.4

watabe007 · ベストアンサー

>こちらはどのような処理をしているのでしょうか？
大きな変更箇所は貴方が提示されたコードに下記を加えたぐらいですね
サブフォルダーにサブフォルダー名.jpg ファイルの有無を確認します
If objFSO.FileExists(sPath & sSubFol & "\" & sSubFol & ".jpg") Then
　　有れば転記する列を12列から始めます。(11列にはsSubFol & ".jpg"を入れます)
　　nCol = 12
Else
　　sSubFol & ".jpg"が無いので転記する列を11列から始めます
　　nCol = 11
End If
以上のことを踏まえてステップインで実行して変数の変化などを観察しながら
行うと勉強になりますよ

お礼

ご回答ありがとうございます。

回答No.3

watabe007

NO1です。
>商品番号が１２３、サブフォルダ名１２３だとして、
勘違いしていました。
サブフォルダ名と同じ商品番号が有れば先頭に表示するのですね
Sub Test2()
　　Dim objFSO As Object
　　Dim sPath As String, sSubFol As String, sFileName As String
　　Dim nRow As Long, nCol As Long
　　Set objFSO = CreateObject("Scripting.FileSystemObject")
　　sPath = "C:\Users\Owner\Downloads\base\setting_000002016\"
　　nRow = 2
　　sSubFol = Cells(nRow, 1).Text
　　Do While sSubFol <> ""
　　　　nCol = 11
　　　　sFileName = Dir(sPath & sSubFol & "\*.jpg")
　　　　If objFSO.FileExists(sPath & sSubFol & "\" & sSubFol & ".jpg") Then
　　　　　　nCol = 12
　　　　Else
　　　　　　nCol = 11
　　　　End If
　　　　Do While sFileName <> ""
　　　　　　If sFileName = sSubFol & ".jpg" Then
　　　　　　　　Cells(nRow, 11) = sFileName
　　　　　　Else
　　　　　　　　Cells(nRow, nCol) = sFileName
　　　　　　　　nCol = nCol + 1
　　　　　　End If
　　　　　　sFileName = Dir()
　　　　Loop
　　　　nRow = nRow + 1
　　　　sSubFol = Cells(nRow, 1).Text
　　Loop
　　Set objFSO = Nothing
End Sub

お礼

ご回答ありがとうございます。

補足

こちらはどのような処理をしているのでしょうか？
勉強のため詳しく教えていただけないでしょうか？

回答No.2

HohoPapa

こんなコードはいかがでしょうか。

Sub Sample()

　Dim sPath As String
　Dim nRow As Integer
　Dim nCol As Integer
　Dim sFileName As String
　Dim sSubFol As String
　Dim FSO As Object

　sPath = "C:\Users\Owner\Downloads\base\setting_000002016\"
　nRow = 2
　sSubFol = Cells(nRow, 1).Text
　Set FSO = CreateObject("Scripting.FileSystemObject")

　Do While sSubFol <> ""

　　nCol = 11
　　sFileName = Dir(sPath & sSubFol & "\*.jpg")

　　Do While sFileName <> ""
　　　If FSO.GetBaseName(sFileName) = sSubFol Then
　　　　Cells(nRow, nCol) = sFileName
　　　　nCol = nCol + 1
　　　End If
　　　sFileName = Dir()
　　Loop

　　sFileName = Dir(sPath & sSubFol & "\*.jpg")
　　Do While sFileName <> ""
　　　If FSO.GetBaseName(sFileName) <> sSubFol Then
　　　　Cells(nRow, nCol) = sFileName
　　　　nCol = nCol + 1
　　　End If
　　　sFileName = Dir()
　　Loop
　　nRow = nRow + 1

　　sSubFol = Cells(nRow, 1).Text

　Loop

　Set FSO = Nothing

End Sub

お礼

ご回答ありがとうございます。

回答No.1

watabe007

参考に
Sub Test()
　　Dim objFSO As Object
　　Dim sPath As String, sSubFol As String, sFileName As String
　　Dim nRow As Long, nCol As Long
　　Set objFSO = CreateObject("Scripting.FileSystemObject")
　　sPath = "C:\Users\Owner\Downloads\base\setting_000002016\"
　　nRow = 2
　　sSubFol = Cells(nRow, 1).Text
　　Do While sSubFol <> ""
　　　　nCol = 11
　　　　sFileName = Dir(sPath & sSubFol & "\*.jpg")
　　　　If objFSO.FileExists(sPath & sSubFol & "\123.jpg") Then
　　　　　　nCol = 12
　　　　Else
　　　　　　nCol = 11
　　　　End If
　　　　Do While sFileName <> ""
　　　　　　If sFileName = "123.jpg" Then
　　　　　　　　Cells(nRow, 11) = sFileName
　　　　　　Else
　　　　　　　　Cells(nRow, nCol) = sFileName
　　　　　　　　nCol = nCol + 1
　　　　　　End If
　　　　　　sFileName = Dir()
　　　　Loop
　　　　nRow = nRow + 1
　　　　sSubFol = Cells(nRow, 1).Text
　　Loop
End Sub

お礼

ご回答ありがとうございます。