こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

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でつくられたプログラムです。

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

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

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

投稿日時 - 2018-05-25 20:41:09

QNo.9501918

困ってます

質問者が選んだベストアンサー

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

投稿日時 - 2018-05-26 17:54:39

お礼

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

投稿日時 - 2018-05-28 20:09:09

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(4)

ANo.3

NO1です。
>商品番号が123、サブフォルダ名123だとして、
勘違いしていました。
サブフォルダ名と同じ商品番号が有れば先頭に表示するのですね
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

投稿日時 - 2018-05-26 10:24:44

補足

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

投稿日時 - 2018-05-26 17:12:50

お礼

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

投稿日時 - 2018-05-28 20:09:22

ANo.2

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

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

投稿日時 - 2018-05-25 22:38:50

お礼

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

投稿日時 - 2018-05-28 20:09:33

ANo.1

参考に
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

投稿日時 - 2018-05-25 21:44:37

お礼

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

投稿日時 - 2018-05-28 20:09:40

あなたにオススメの質問