Excel 使用fso搜索字符串/单词、文件名并提取到新工作表中_Excel_Vba

Excel 使用fso搜索字符串/单词、文件名并提取到新工作表中

excel vba

Excel 使用fso搜索字符串/单词、文件名并提取到新工作表中,excel,vba,Excel,Vba,我之前在一位同事的帮助下，提出了一个与我正在发布的新问题相关的问题，所以它所做的是在一个文件夹中循环，并将指定范围提取到新创建的excel工作表中。但是我仍然面临两个问题 1）如何获取文件夹中的所有文件名（例如6个文件），并将其写入新创建的工作表中，该工作表就在相同格式的复制范围旁边？Header=E1，文件名从E2开始 2）是否有一种方法可以搜索文件夹中所有文件中的字符串/单词，并再次执行相同的操作，即以相同的格式将它们提取到新创建的工作表中这是密码 Option Explicit S

我之前在一位同事的帮助下，提出了一个与我正在发布的新问题相关的问题，所以它所做的是在一个文件夹中循环，并将指定范围提取到新创建的excel工作表中。但是我仍然面临两个问题

1）如何获取文件夹中的所有文件名（例如6个文件），并将其写入新创建的工作表中，该工作表就在相同格式的复制范围旁边？Header=E1，文件名从E2开始

2）是否有一种方法可以搜索文件夹中所有文件中的字符串/单词，并再次执行相同的操作，即以相同的格式将它们提取到新创建的工作表中

这是密码

Option Explicit

Sub ScanFiles()

    Application.ScreenUpdating = False

    Dim wkb As Workbook
    Set wkb = ThisWorkbook

    Dim wks As Worksheet
    Set wks = Worksheets.Add
    wks.Name = "NewWorksheet"

    ' Add Worksheet to accept data
    With wks
        '.Range("A2:I20").ClearContents -> No longer needed as you create a new sheet
        .Range("A1:D1") = Array("Test", "Temp", "Start", "Type")
    End With

    ' Set your copy ranges
    Dim CopyRange(1 To 4) As String
    CopyRange(1) = "A18"
    CopyRange(2) = "A19"
    CopyRange(3) = "A14"
    CopyRange(4) = "A19"

    ' Early Binding - Add "Microsoft Scripting Runtime" Reference
    Dim FSO As New Scripting.FileSystemObject

    ' Set FolderPath
    Dim FolderPath As String
    FolderPath = "c:\Users\Desktop\Tryout\"

    ' Set Folder FSO
    Dim Folder As Scripting.Folder
    Set Folder = FSO.GetFolder(FolderPath)

    ' Loop thru each file -> Assuming only 6 files 
    Dim File As Scripting.File
    For Each File In Folder.Files

        Dim wkbData As Workbook
        Set wkbData = Workbooks.Open(File.path)

        Dim wksData As Worksheet
        Set wksData = wkbData.Worksheets("Sheet1") ' -> Assume this file has only 1 worksheet

        Dim BlankRow As Long
        BlankRow = wks.Range("A" & wks.Rows.Count).End(xlUp).Row + 1

        Dim i As Long
        For i = 1 To 4
            wks.Cells(BlankRow, i).Value = wksData.Range(CopyRange(i)).Value
        Next i

        wkbData.Close False

    Next File

    Range("A:I").EntireColumn.AutoFit
    Application.ScreenUpdating = True

End Sub

谢谢你的帮助！如果能够提供一小部分代码，那就更好了

1）

FSO

有一些很棒的特性。其中之一是

.Name

。在这条直线之后：

For Each File In Folder.Files

.Range("A1:D1") = Array("Test", "Temp", "Start", "Type")

写：

Debug.Print File.Name

在即时窗口中，您将看到文件名。然后，您可以通过简单引用将结果复制到工作表中，如下所示：

wks.Range("E1").Value = File.Name

标题仅在这一行结束：

For Each File In Folder.Files

.Range("A1:D1") = Array("Test", "Temp", "Start", "Type")

2）要搜索单词，最快捷最简单的方法是使用like函数。同样，您将使用与前面相同的方法，但使用

If

语句

If File.Name Like "*SomeString*" Then
    wksFSO.Cells(1, 1) = File.Name
End If

注意在sear字符串前后使用通配符

。根据需要修改此选项。很明显，我的结果指向一个单元格。如果您期望得到很多结果，那么如果期望得到更多结果，您可以将其更新为写入新行。要将它们提取到新的

工作表

，我首先要设置

工作表

，并复制名称。像这样：

Worksheets.Add

现在，要将所有这些总结成相同的代码，可以这样编写：

Option Explicit

Sub ScanFiles()

    Application.ScreenUpdating = False

    Dim wks As Worksheet
    Set wks = Worksheets.Add
    wks.Name = "NewWorksheet"

    ' New worksheet for question 2
    Dim wksFSO As Worksheet
    Set wksFSO = Worksheets.Add
    wksFSO.Name = "FSOWorksheet"

    ' Add headers data
    With wks
        .Range("A1:E1") = Array("Test", "Temp", "Start", "Type", "FileName")
    End With

    ' Set your copy ranges
    Dim CopyRange(1 To 4) As String
    CopyRange(1) = "A18"
    CopyRange(2) = "A19"
    CopyRange(3) = "A14"
    CopyRange(4) = "A19"

    ' Early Binding - Add "Microsoft Scripting Runtime" Reference
    Dim FSO As New Scripting.FileSystemObject

    ' Set FolderPath
    Dim FolderPath As String
    FolderPath = "c:\Users\Desktop\Tryout\"

    ' Set Folder FSO
    Dim Folder As Scripting.Folder
    Set Folder = FSO.GetFolder(FolderPath)

    ' Loop thru each file -> Assuming only 6 files
    Dim File As Scripting.File
    For Each File In Folder.Files

        ' If loop looking for specific files and copy to new FSOWorksheet
        If File.Name Like "*SomeString*" Then
            wksFSO.Cells(1, 1) = File.Name
        End If

        Dim wkbData As Workbook
        Set wkbData = Workbooks.Open(File.Path)

        Dim wksData As Worksheet
        Set wksData = wkbData.Worksheets("Sheet1") ' -> Assume this file has only 1 worksheet

        Dim BlankRow As Long
        BlankRow = wks.Range("A" & wks.Rows.Count).End(xlUp).row + 1

        Dim i As Long
        For i = 1 To 4
            wks.Cells(BlankRow, i).Value = wksData.Range(CopyRange(i)).Value
        Next i

        ' Write filename in col E
        wks.Cells(BlankRow, 5).Value = File.Name

        wkbData.Close False

    Next File

    Range("A:I").EntireColumn.AutoFit
    Application.ScreenUpdating = True

End Sub

1）

FSO

有一些很棒的功能。其中之一是

.Name

。在这条直线之后：

For Each File In Folder.Files

.Range("A1:D1") = Array("Test", "Temp", "Start", "Type")

写：

Debug.Print File.Name

在即时窗口中，您将看到文件名。然后，您可以通过简单引用将结果复制到工作表中，如下所示：

wks.Range("E1").Value = File.Name

标题仅在这一行结束：

For Each File In Folder.Files

.Range("A1:D1") = Array("Test", "Temp", "Start", "Type")

2）要搜索单词，最快捷最简单的方法是使用like函数。同样，您将使用与前面相同的方法，但使用

If

语句

If File.Name Like "*SomeString*" Then
    wksFSO.Cells(1, 1) = File.Name
End If

注意在sear字符串前后使用通配符

工作表

，我首先要设置

工作表

，并复制名称。像这样：

Worksheets.Add

现在，要将所有这些总结成相同的代码，可以这样编写：

Option Explicit

Sub ScanFiles()

    Application.ScreenUpdating = False

    Dim wks As Worksheet
    Set wks = Worksheets.Add
    wks.Name = "NewWorksheet"

    ' New worksheet for question 2
    Dim wksFSO As Worksheet
    Set wksFSO = Worksheets.Add
    wksFSO.Name = "FSOWorksheet"

    ' Add headers data
    With wks
        .Range("A1:E1") = Array("Test", "Temp", "Start", "Type", "FileName")
    End With

    ' Set your copy ranges
    Dim CopyRange(1 To 4) As String
    CopyRange(1) = "A18"
    CopyRange(2) = "A19"
    CopyRange(3) = "A14"
    CopyRange(4) = "A19"

    ' Early Binding - Add "Microsoft Scripting Runtime" Reference
    Dim FSO As New Scripting.FileSystemObject

    ' Set FolderPath
    Dim FolderPath As String
    FolderPath = "c:\Users\Desktop\Tryout\"

    ' Set Folder FSO
    Dim Folder As Scripting.Folder
    Set Folder = FSO.GetFolder(FolderPath)

    ' Loop thru each file -> Assuming only 6 files
    Dim File As Scripting.File
    For Each File In Folder.Files

        ' If loop looking for specific files and copy to new FSOWorksheet
        If File.Name Like "*SomeString*" Then
            wksFSO.Cells(1, 1) = File.Name
        End If

        Dim wkbData As Workbook
        Set wkbData = Workbooks.Open(File.Path)

        Dim wksData As Worksheet
        Set wksData = wkbData.Worksheets("Sheet1") ' -> Assume this file has only 1 worksheet

        Dim BlankRow As Long
        BlankRow = wks.Range("A" & wks.Rows.Count).End(xlUp).row + 1

        Dim i As Long
        For i = 1 To 4
            wks.Cells(BlankRow, i).Value = wksData.Range(CopyRange(i)).Value
        Next i

        ' Write filename in col E
        wks.Cells(BlankRow, 5).Value = File.Name

        wkbData.Close False

    Next File

    Range("A:I").EntireColumn.AutoFit
    Application.ScreenUpdating = True

End Sub

你好很抱歉回复太晚，非常感谢您的回复，但是我不仅要查找特定的文件，还要查找特定的单词/字符串，然后将其提取出来，继续该行。例如，“Smart”是我要搜索和提取的单词：（我可以知道编码会是什么样子吗？如果File.Name像“*SomeString*”一样，您可以修改这一行

然后

如果您只想在该文件上运行代码，那么将循环移动到

If

station.hi中，非常感谢您的回答，但是您提供的代码涵盖了我的第一个问题，现在我需要搜索文件内的字符串，这是问题2，因此使用您的编码“``If file.Name，比如“SomeString”然后，``我想知道如何更改它，使它不会查找文件名，而是查找文件中的字符串，并以与其他文件相同的格式将其提取出来？您需要打开文件进行搜索。我会将其标记为搜索文件部分的第一部分的答案，但是我仍然不确定如何搜索文件中的字符串！很抱歉回复太晚，非常感谢您的回复，但是我不仅要查找特定的文件，还要查找特定的单词/字符串，然后将其提取出来继续该行，例如“Smart”是我要搜索和提取的单词：（我可以知道编码会是什么样子吗？如果File.Name像“*SomeString*”一样，您可以修改这一行

然后

如果您只想在该文件上运行代码，那么将循环移动到

If