Excel VBA复制单元格丢失Tab制表位的解决方法问询

问题背景 #

需要批量将指定文件夹内所有XLS文件的E1单元格值复制到Q1，最初使用Excel对象模型编写的脚本执行后，出现了所有行中"CR"前的Tab制表位丢失的问题，导致文件无法被内部工具识别。尝试过在赋值时追加& vbTab，但仅对第一行有效且未解决根本问题；也试过用Notepad++批量替换，但更倾向于自动化脚本方案。

初始代码（存在制表位丢失问题） #

Sub header_austauschen()
    ChDir (ActiveWorkbook.Sheets("Tabelle1").Range("D8"))
    Nextfile = Dir("*.XLS")
    While Nextfile <> ""
        Workbooks.Open (Nextfile)
        Workbooks(Nextfile).Sheets(1).Range("Q1") = Workbooks(Nextfile).Sheets(1).Range("E1")
        Workbooks(Nextfile).Save
        Workbooks(Nextfile).Close
        Nextfile = Dir()
    Wend
End Sub

中间尝试的代码（误修改所有行） #

结合建议改为直接读写文件内容，但代码逻辑错误，导致每一行都被处理，而非仅修改第一行：

Sub header_austauschen_neu()
    Dim j As Integer
    Dim file As String, newFile As String
    Dim lines() As String, words() As String
    Dim i As Integer
    
    DataDir = ActiveWorkbook.Sheets("Tabelle1").Range("D8") '从表格中获取用户输入的文件路径
    MsgBox ("Alle *.XLS Dateien im Ordner" & vbCrLf & vbCrLf & DataDir & vbCrLf & vbCrLf & "werden verarbeitet! Zum Abbrechen Strg+Pause drücken.")
    ChDir (DataDir)
    nextfile = Dir("*.XLS")
    MsgBox (nextfile) '临时检查点
    j = 0
    While nextfile <> ""
        j = j + 1
        file = DataDir & "\" & nextfile
        newFile = DataDir & "\OUT\" & nextfile
        MsgBox (file & " -> " & newFile) '临时检查点
        Open file For Input As #1
        Open newFile For Output As #2
        Do While Not EOF(1)
            Line Input #1, textline
            lines = Split(textline, vbNewLine)
            For i = 0 To UBound(lines)
                If i = 0 Then
                    words = Split(lines(i), vbTab)
                    words(16) = words(4)
                    Print #2, Join(words, vbTab)
                Else
                    Print #2, lines(i)
                End If
            Next i
        Loop
        Close #1
        Close #2
        
        nextfile = Dir()
    Wend
    MsgBox ("Insgesamt " & j & " Dateien wurden verarbeitet.")
End Sub

最终修复代码 #

修复后的代码通过标记bFirstLine仅处理第一行内容，同时保留其他行的原始格式，还自动创建输出文件夹避免报错：

Sub processFiles()
    Dim bFirstLine As Boolean
    Dim file As String, newFile As String
    Dim words() As String
    Dim i As Integer
    
    DataDir = "c:\test"
    ChDir (DataDir)
    '如果输出文件夹不存在则创建
    If Dir(DataDir & "\OUT", vbDirectory) = "" Then
        MkDir DataDir & "\OUT"
    End If
    nextfile = Dir("*.XLS")
    While nextfile <> ""
        If (Right(nextfile, 4)) = ".XLS" Then
            file = DataDir & "\" & nextfile
            newFile = DataDir & "\OUT\" & nextfile
            bFirstLine = True
            Open file For Input As #1
            Open newFile For Output As #2
            Do While Not EOF(1)
                Line Input #1, textline
                If bFirstLine Then
                    '拆分第一行的制表位内容，替换第17个字段（对应Q列）为第5个字段（对应E列）
                    words = Split(textline, vbTab)
                    words(16) = words(4)
                    Print #2, Join(words, vbTab)
                    bFirstLine = False
                Else
                    '直接输出其他行，不做修改
                    Print #2, textline
                End If
            Loop
            Close #1
            Close #2
        End If
        nextfile = Dir()
    Wend
End Sub

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