如何使用VBA将Excel中存储的标签批量写入对应本地文件

前置说明 #

• 依赖Shell.Application对象实现扩展属性写入，仅支持NTFS分区存储的文件
• Win10/Win11系统下「标签」属性的默认索引为18，若系统版本不同无法写入，可自行遍历属性索引确认对应值
• 代码默认跳过A列为空、文件不存在、无读取写入权限的条目

完整代码 #

Sub WriteFileTagsFromExcel()
    Dim shellApp As Object
    Dim targetFolder As Object
    Dim fileItem As Object
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim successCount As Long
    Dim failCount As Long
    Dim folderPath As String
    
    ' 读取目标文件夹路径
    folderPath = UserForm_Tag.FolderLocation_TextBox.Value
    ' 校验路径是否存在
    If Dir(folderPath, vbDirectory) = "" Then
        MsgBox "指定的目标文件夹不存在，请检查输入路径", vbCritical
        Exit Sub
    End If
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    
    ' 初始化对象
    Set shellApp = CreateObject("Shell.Application")
    Set targetFolder = shellApp.Namespace(folderPath)
    Set ws = ThisWorkbook.Sheets("Sheet1")
    ' 获取最后一行行号
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    successCount = 0
    failCount = 0
    
    ' 遍历行，默认第1行为表头，从第2行开始执行
    For i = 2 To lastRow
        Dim fullFileName As String
        Dim tagStr As String
        fullFileName = Trim(ws.Cells(i, "A").Value)
        tagStr = Trim(ws.Cells(i, "B").Value)
        
        ' 跳过空行
        If fullFileName = "" Then GoTo NextLine
        
        ' 校验文件是否存在
        If Dir(fullFileName) = "" Then
            failCount = failCount + 1
            GoTo NextLine
        End If
        
        On Error Resume Next
        ' 获取文件对象
        Set fileItem = targetFolder.ParseName(Dir(fullFileName))
        ' 写入标签属性，索引18对应Win10/11的「标签」属性
        targetFolder.SetDetailsOf fileItem, 18, tagStr
        If Err.Number = 0 Then
            successCount = successCount + 1
        Else
            failCount = failCount + 1
            Err.Clear
        End If
        On Error GoTo 0
        
NextLine:
    Next i
    
    ' 输出执行结果
    MsgBox "执行完成：成功写入" & successCount & "个文件，失败" & failCount & "个文件", vbInformation
    
    ' 释放对象
    Set fileItem = Nothing
    Set targetFolder = Nothing
    Set shellApp = Nothing
    Set ws = Nothing
End Sub

使用说明 #

1. 确保UserForm_Tag窗口的FolderLocation_TextBox控件已正确输入目标文件夹路径
2. Sheet1的A列填入待写入标签的文件完整路径，B列填入对应要写入的标签内容
3. 运行上述宏即可批量完成写入

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