如何取同一目录下工作薄单位名

yfxfsj

取同一目录下工作薄单位名，见附件

liulang0808

https://club.excelhome.net/threa ... tml?_dsign=73cffde5
遍历文件，split拆分文件名，取需求字段

longwin

Sub test()
    fpath = ThisWorkbook.Path
    fname = Dir(fpath & "\*.xls")
    l = 2
    Do While fname <> ""
        If fname <> ThisWorkbook.Name Then
            fn = Split(Split(fname, ".")(0), "-")
            Cells(l, 1) = fn(UBound(fn))
            l = l + 1
        End If
        fname = Dir
    Loop
End Sub

shiruiqiang

遍历表，取split(表.name,".")(0)

Qs18

Sub qs() '2024/7/2取同一目录下工作薄单位名
    Dim fso As Object, folderPath As String, fileName As String, file As Object
    Dim rw
    Set fso = CreateObject("Scripting.FileSystemObject")
    folderPath = ThisWorkbook.Path & "\"
    Set ws = ActiveSheet
    rw = 1
    For Each file In fso.GetFolder(folderPath).Files
    If InStr(file, ThisWorkbook.Name) = 0 Then
        rw = rw + 1
        x = Mid(file, VBA.InStrRev(file, "\") + 1, Len(file) - InStrRev(file, "\") - 4)
        ws.Cells(rw, 1).Value = Mid(x, InStrRev(x, "-") + 1)
    End If
    Next file
    Set fso = Nothing: Set file = Nothing
    MsgBox "完成"
End Sub

Qs18

试一下...........

Qs18

试一下..........

小凡、、、

cai2532

Sub 获取文件名()
    On Error Resume Next
    Application.ScreenUpdating = False
    With ActiveSheet
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Title = "请选择文件夹"
            .InitialFileName = ThisWorkbook.Path & "\"
            If .Show = -1 Then
                myPath = .SelectedItems(1) & "\"
            Else
                Exit Sub
            End If
        End With
        .UsedRange.Offset(1).Clear
        .Cells(1, 1) = "单位名"
        i = .Range("A65536").End(xlUp).Row
        myTxt = Dir(myPath, 31)
        Do While myTxt <> ""
            If myTxt <> ThisWorkbook.Name And myTxt <> "." And myTxt <> ".." Then
                i = i + 1
                .Cells(i, 1) = Split(Split(myTxt, ".")(0), "-")(1)
            End If
            myTxt = Dir
        Loop
    End With
    Application.ScreenUpdating = True
End Sub

yfxfsj

Qs18 发表于 2024-7-2 16:11
Sub qs() '2024/7/2取同一目录下工作薄单位名
    Dim fso As Object, folderPath As String, fileName As ...

这个本工作薄的名不需要取哦