如果文件名包含特定的文本，然后从文件名（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。