Question

我正在尝试在所选文件夹中的所有excel工作簿中提取工作表的名称。这些代码不会在IF行上提醒类型不匹配。

我对vba中的FSO，对象和外壳函数不是很熟悉，所以如果我做错了，请指出，谢谢。

Sub extractname()

    Dim Fso, Fld, sFld, Fl
    Dim Wb As Workbook, Sheeet As Worksheet, Sh As Worksheet
    Dim Arr
    Dim count As Long

    count = 0

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Fld = Fso.getfolder(CreateObject("Shell.Application").BrowseForFolder(0, "Please select folder", 0, "").Self.Path & "")
    Set Sheeet = ActiveSheet
        For Each Fl In Fld.Files
            'On Error Resume Next
            If Fl.Name Like "*.xls" Or "*.xlsm" Or "*.xlsx" Then
                count = count + 1
                Set Wb = Workbooks.Open(Fl)
                ReDim Arr(count, 4)
                Arr(count, 1) = Wb.Worksheets(1).Name.Text
                Arr(count, 2) = Wb.Worksheets(2).Name.Text
                Arr(count, 3) = Wb.Worksheets(3).Name.Text
                Arr(count, 4) = Wb.Worksheets(4).Name.Text
                Wb.Close
            End If
        Next
    Sheeet.[B65536].End(3).Resize(count, 4) = Arr

End Sub

我希望应该将工作表名称的4列制成表格，但是代码无法运行。

Answer 1

更改：

If Fl.Name Like "*.xls" Or "*.xlsm" Or "*.xlsx" Then

到

If Fl.Name Like "*.xls" Or Fl.Name Like "*.xlsm" Or Fl.Name Like "*.xlsx" Then

为什么不只使用：

If Fl.Name Like "*.xls*" Then

编辑1 ：修改后的代码

下面的代码将为您提供所需的信息（如果我正确理解了您的代码意图）。

Option Explicit

Sub extractname()

    Dim Fso, Fld, sFld, Fl
    Dim Wb As Workbook, Sheeet As Worksheet, Sh As Worksheet
    Dim Arr
    Dim count As Long, i As Long, ShtCount As Long

    count = 0

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Fld = Fso.getfolder(CreateObject("Shell.Application").BrowseForFolder(0, "Please select folder", 0, "").Self.Path & "")
    Set Sheeet = ActiveSheet

    For Each Fl In Fld.Files
        ReDim Arr(1 To Fld.Files.count, 1 To 4)

        If Fl.Name Like "*.xls*" Then
            count = count + 1
            Set Wb = Workbooks.Open(Fl)

            ' need to make sure each workbook has 4 sheet (not less)
            ShtCount = Wb.Worksheets.count
            If ShtCount > 4 Then ShtCount = 4

            For i = 1 To ShtCount
                Arr(count, i) = Wb.Worksheets(i).Name
            Next i

            Wb.Close
        End If
    Next Fl

    Sheeet.Range("B" & Sheeet.Cells(Sheeet.Rows.count, "B").End(xlUp).Row).Resize(count, 4) = Arr

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

Answer 2

Sub F()

    '// Tools -> References -> Microsoft Scripting Runtime

    Dim fso As FileSystemObject, xFile As File
    Dim strFolder$
    Dim book As Workbook

    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Title = "Select folder"
        If .Show() Then strFolder = .SelectedItems(1) Else Exit Sub
    End With
    Set fso = New FileSystemObject
    For Each xFile In fso.GetFolder(strFolder).Files
        If fso.GetExtensionName(xFile.Name) Like "xls*" Then
            Set book = Workbooks.Open(xFile.Path)
            '// Do your thing
        End If
    Next

End Sub

Answer 3

您的代码存在一些问题。
1）您无法重新调整VBA阵列中的行

2）如果您的文件没有完全4个工作表，则会出错
3）如果您在重新格式化时不保留数组，则会丢失所有数据。

您仍然可以使用FSO代替打开文件夹对话框的宏。

Option Base 1  'so that the VBA array starts on row 1 and column 1, not 0,0
Sub Worksheet_names_in_Dir()
Dim direct As String
Dim Arr()
'
' directory Macro
Let direct = UseFolderDialogOpen & "\"
'
  Set Sht = ActiveSheet
f = Dir(direct & "\*.xls*", 7) 'sets f equal to the first file name and only files that are xls* files (XLSX, XLSB, XLSM)
Do While f <> ""        'loops until there are no more files in the direstory

    F1 = direct & f
                        Count = Count + 1
                        ReDim Preserve Arr(4, Count)  'you can't redim the rows in VBA, just the columns
                Set wb = Workbooks.Open(F1)
                wkshts = wb.Sheets.Count    'count number of worksheets in file
                If wkshts > 4 Then wkshts = 4  'to only do 4 worksheets per file or less if there are less than 4 worksheets
                For i = 1 To wkshts
                    Arr(i, Count) = wb.Worksheets(i).Name
                Next i
                wb.Close


     f = Dir            'set f equal to the next file name in the directory

Loop

'this transposes the array and writes it to the active worksheet starting in A!, you can change this to fit your needs
Sht.Range("A1:D" & Count).Value = WorksheetFunction.Transpose(Arr)

End Sub

Public Function UseFolderDialogOpen() As String
    Dim lngCount As Long

    ' Open the folder dialog
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False 'only allows the user to pick one directory
        .Title = "pick directory"
        .Show

        ' Set Current Folder Path
        For lngCount = 1 To .SelectedItems.Count
            UseFolderDialogOpen = .SelectedItems(lngCount)
        Next lngCount

    End With

End Function

尝试提取工作簿中的工作表名称

3 个答案: