如果文件名包含特定的文本，然後從文件名（Excel VBA）

Question

拉信息我有一個約140,000測試文件的數據庫。我期待循環遍歷每個文件夾，並從文本和excel文件的文件名中提取信息，以便將數據組織得更好一些。

我找到了選擇文件夾路徑的方法，並使用下面的代碼導入關於每個文件的信息。這很好，除了我只想從excel和文本文件中提取信息，我也想從文件名中提取額外的文本信息。比如我可能有一個名爲文件：

「444555_CAT1010EL_650-700-800C-2小時laging不CH4.txt」

而且我會想打印：

• 的6個號碼的在這個例子中的名字的開頭（它們可以是任何東西）在一列中「444555」

• 在另一列中打印「1010EL」前面的3個字母（它們可以是任何東西）。在這個例子中「CAT」

• 「CH4」中的最後一欄，甚至有「CH4」一列，在該列

• 如果文件名中包含「CH4」把一個X有一列「laging」，如果文件名中包含「laging」，則在任何位置放入一個X在該列中

提前感謝您的幫助。

Sub Compile3() 
    Dim oShell As Object 
    Dim oFile As Object 
    Dim oFldr As Object 
    Dim lRow As Long 
    Dim iCol As Integer 
    Dim vArray As Variant 
    vArray = Array(10, 0, 1, 156, 2, 4, 144, 146, 183, 185) 

    '0=Name, 31=Dimensions, 1=Size, 163=Vertical Resolution 

    Set oShell = CreateObject("Shell.Application") 
'-------------------ROW INFO INPUT OPTIONS----------------- 
'' 1) 
' lRow = 1 
' 2) find first empty row in database for bottletracker 
' 
    Dim iRow As Long 
    iRow = Cells.find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row 
    lRow = iRow 
'------------------------------------------------------------ 

    With Application.FileDialog(msoFileDialogFolderPicker) 
    .title = "Select the Folder..." 
    If .Show Then 
     Set oFldr = oShell.Namespace(.SelectedItems(1)) 
     With oFldr 
     'Column header information 
     For iCol = LBound(vArray) To UBound(vArray) 
      Cells(lRow, iCol + 4) = .getdetailsof(.items, vArray(iCol)) 
     Next iCol 

     For Each oFile In .items 
      lRow = lRow + 1 
      For iCol = LBound(vArray) To UBound(vArray) 
      Cells(lRow, iCol + 4) = .getdetailsof(oFile, vArray(iCol)) 
      Next iCol 
     Next oFile 
     End With 
    End If 
    End With 
End Sub 

Answer 1

我想用這段代碼。最後有三個單獨的程序，用於查找工作表中的最後一個單元格，返回文件夾並返回文件夾內的所有文件。

主代碼然後查看每個文件名並從中提取所需的信息。
注意，此代碼：InStr(sFileName, "CAT") <> 0將返回TRUE/FALSE，具體取決於文本「CAT」是否在文件名中。 InStr(sFileName, "CAT")返回「CAT」的文本中的位置，並<>0輪流到這一點取決於它是否不同於0

Option Explicit 

Public Sub Test() 

    Dim sFolder As String 
    Dim cFiles As Collection 
    Dim vFile As Variant 
    Dim sFileName As String 
    Dim rLastCell As Range 

    sFolder = GetFolder("S:\DB_Development_DBC\") & Application.PathSeparator 

    Set cFiles = New Collection 
    EnumerateFiles sFolder, "*.xls*", cFiles 
    EnumerateFiles sFolder, "*.txt", cFiles 

    With ThisWorkbook.Worksheets("Sheet1") 
     For Each vFile In cFiles 
      Set rLastCell = LastCell(ThisWorkbook.Worksheets("Sheet1")).Offset(1) 'Find last row 
      sFileName = Mid(vFile, InStrRev(vFile, Application.PathSeparator) + 1) 'Get just file name from path. 
      .Cells(rLastCell.Row, 1) = Left(sFileName, 6) 'First 6 characters. 
      .Cells(rLastCell.Row, 2) = Mid(sFileName, InStr(sFileName, "1010EL") - 3, 3) '3 characters before 1010EL. 
      .Cells(rLastCell.Row, 3) = InStr(sFileName, "CH4") <> 0 'Contains CH4. 
      .Cells(rLastCell.Row, 4) = InStr(sFileName, "laging") <> 0 'Contains laging. 
     Next vFile 
    End With 

End Sub 

Sub EnumerateFiles(ByVal sDirectory As String, _ 
    ByVal sFileSpec As String, _ 
    ByRef cCollection As Collection) 

    Dim sTemp As String 

    sTemp = Dir$(sDirectory & sFileSpec) 
    Do While Len(sTemp) > 0 
     cCollection.Add sDirectory & sTemp 
     sTemp = Dir$ 
    Loop 
End Sub 

Function GetFolder(Optional startFolder As Variant = -1) As Variant 
    Dim fldr As FileDialog 
    Dim vItem As Variant 
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker) 
    With fldr 
     .Title = "Select a Folder" 
     .AllowMultiSelect = False 
     If startFolder = -1 Then 
      .InitialFileName = Application.DefaultFilePath 
     Else 
      If Right(startFolder, 1) <> "\" Then 
       .InitialFileName = startFolder & "\" 
      Else 
       .InitialFileName = startFolder 
      End If 
     End If 
     If .Show <> -1 Then GoTo NextCode 
     vItem = .SelectedItems(1) 
    End With 
NextCode: 
    GetFolder = vItem 
    Set fldr = Nothing 
End Function 

Public Function LastCell(wrkSht As Worksheet, Optional Col As Long = 0) As Range 

    Dim lLastCol As Long, lLastRow As Long 

    On Error Resume Next 

    With wrkSht 
     If Col = 0 Then 
      lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column 
      lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row 
     Else 
      lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column 
      lLastRow = .Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row 
     End If 

     If lLastCol = 0 Then lLastCol = 1 
     If lLastRow = 0 Then lLastRow = 1 

     Set LastCell = wrkSht.Cells(lLastRow, lLastCol) 
    End With 
    On Error GoTo 0 

End Function 

編輯一個布爾值： 我已經更新的代碼包含的其他要求並找到最後一個單元在循環內部，所以它實際上工作。

注：
Mid(sFileName, InStr(sFileName, "1010EL") - 3, 3) - 這個代碼將拋出一個錯誤，如果文本中不包含1010EL。在執行該行之前添加一個支票InStr(sFileName, "1010EL") <> 0。