Question

我有一个大约140,000个测试文件的数据库。我希望遍历每个文件夹并从文本和excel文件的文件名中提取信息，以便更好地组织数据。

我找到了使用以下代码选择文件夹路径并导入有关每个文件的信息的方法。这很好用，除了我只想从excel和文本文件中提取信息，我还想从文件名中提取其他文本信息。例如，我可能有一个名为：

的文件

“444555_CAT1010EL_650-700-800C-2hr laging NOT 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的检查。

如果文件名包含特定文本，则从文件名中提取信息（excel vba）

1 个答案: