如何提取打开文件的文件名并批量填充至对应行？

核心解决思路 #

• 提取纯文件名：用Dir()函数直接从完整路径中提取文件名，无需额外组件
• 批量填充：先计算源文件的数据行数，定位目标工作表的起始填充行，一次性给对应区域赋值，而非单个单元格

修改后的完整代码 #

Sub Get_Data_From__File()

    Dim WScopy As Worksheet
    Dim WSdest As Worksheet
    Dim desWB As Workbook
    Dim FileToOpen As Variant
    Dim LastRow As Long
    Dim startRow As Long
    Dim pasteRows As Long
    Dim fileNameOnly As String ' 存储纯文件名
    
    Set desWB = ThisWorkbook
    Set WSdest = desWB.Sheets("Sheet1")

    Application.ScreenUpdating = False
    
    FileToOpen = Application.GetOpenFilename(Title:="Browse for Incident File", FileFilter:="Excel Files (*.xls*), *xls*")
    
    If FileToOpen <> False Then
        ' 提取纯文件名
        fileNameOnly = Dir(FileToOpen)
        
        Set OpenBook = Application.Workbooks.Open(FileToOpen)
        LastRow = OpenBook.Sheets(1).Range("A1048576").End(xlUp).Row
        pasteRows = LastRow - 1 ' 计算要复制的数据行数（从第2行开始）
        
        ' 复制A列数据
        OpenBook.Sheets(1).Range("A2:A" & LastRow).Copy
        startRow = WSdest.Cells(WSdest.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
        WSdest.Cells(startRow, "A").PasteSpecial xlPasteValuesAndNumberFormats
        
        ' 复制B列对应的数据（原E列）
        OpenBook.Sheets(1).Range("E2:E" & LastRow).Copy
        WSdest.Cells(startRow, "B").PasteSpecial xlPasteValuesAndNumberFormats
        
        ' 复制D列对应的数据（原AF列）
        OpenBook.Sheets(1).Range("AF2:AF" & LastRow).Copy
        WSdest.Cells(startRow, "D").PasteSpecial xlPasteValuesAndNumberFormats
        
        ' 批量填充纯文件名到C列对应行
        WSdest.Range("C" & startRow & ":C" & startRow + pasteRows - 1).Value = fileNameOnly
     
        OpenBook.Close False
        Application.CutCopyMode = False
        Application.ScreenUpdating = True
    End If

End Sub

关键修改说明 #

1. 提取纯文件名：新增fileNameOnly = Dir(FileToOpen)，Dir()函数自动返回路径中的最后一个文件名称，直接得到无路径的纯文件名
2. 批量填充逻辑：
   • pasteRows = LastRow - 1：计算源数据的总行数（从第2行开始统计）
   • startRow：提前记录目标工作表的起始填充行，避免多次调用End(xlUp)导致定位偏差
   • 用Range对象一次性给C列对应区域赋值，实现批量填充，替代原代码的单个单元格赋值

内容的提问来源于stack exchange，提问作者Charisma