Excel VBA - 将 WhatsApp 聊天记录文件导入 Excel 工作表的问题

Question

这是典型的 WhatsApp 历史聊天文件 (.txt) 在记事本中打开时的样子。

请注意，示例中有 4 条消息，每条消息都以日期/时间戳和用户名开头。 此外，还有一些字符标志着每条消息的结束（对我来说似乎是 Chr(10)）。

此外，第三条消息（待购买清单）由多行组成，在 WhatsApp 聊天中通过按 Enter 键来实现。

我的目标是将上面的数据导入到 Excel 工作表中，这样四条消息中的每一条都将单独排成一行，如下所示：

到目前为止，我一直在尝试使用 Workbook.OpenText 方法，但失败了。问题是待购买清单的多行以不同的行结束，而不是被视为一条完整的消息。

我也需要一个快速而优雅的解决方案，因为我需要处理包含数千条消息的大型聊天文件。 所以，当然，我可以根据行是否有日期/时间/用户名戳来循环和合并行，但这需要大量时间处理大文件。

编辑： 请在下面找到我目前用于导入 .txt 文件的代码。我并没有要求一个优雅的解决方案，如果结果是这样，我很抱歉。我的意思是我希望它最终变得优雅，只需要一两条或更多线索。

Sub ImportTXT ()

ChatFileNm = Application.GetOpenFilename(FileFilter:="Text Files (*.txt), >*.txt", Title:="Select Chat File To Be Opened")

If ChatFileNm = False Then Exit Sub

SourceSheet = FSO.GetBaseName(ChatFileNm)

Workbooks.OpenText filename:= _
        ChatFileNm, _
        Origin:=65001, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
        xlTextQualifierNone, ConsecutiveDelimiter:=False, _ 
        Tab:=False,>Semicolon:=False, _
        Comma:=False, Space:=False, FieldInfo:=Array(Array(1, 1), _
        Array(2, 1)), DecimalSeparator:=".", ThousandsSeparator:=",", _
        TrailingMinusNumbers:=True

End Sub

Answer 1

好的，既然 OpenText 方法不适合你，让我们从这样的东西开始与FileSystemObject 相比，由于您处理的是原始文本/数据，因此您将比仅使用Workbooks.OpenText 拥有更大的灵活性。

如果您的文本文件被破坏（就像您提供的屏幕截图所示），我们可能需要添加一些条件逻辑来识别每个“行”何时开始，但要开始，让我们看看它是如何工作的.

它将开始写入 A 列中的每一行，从第 1 行开始，然后依次写入每个后续行的第 2+ 行。

Option Explicit
Sub f()
Dim ChatFileNm
Dim FF As Long
Dim destination As Range
Dim ctr As Long
Dim ln$

ChatFileNm = Application.GetOpenFilename(FileFilter:="Text Files (*.txt), >*.txt", Title:="Select Chat File To Be Opened")
If ChatFileNm = False Then Exit Sub
Set destination = Range("A1")
FF = FreeFile
Open ChatFileNm For Input As FF
Do Until EOF(FF)
    Line Input #FF, ln
    'Write the line in to the destination
    destination.Offset(ctr).Value = ln
    'Increment the counter
    ctr = ctr + 1
Loop
'Release the lock on the file
Close FF

End Sub

或者，从文件中构建整个文本字符串，并使用 Split 函数和 Chr(10) 作为分隔符：

Option Explicit
Sub f()
Dim ChatFileNm
Dim FF As Long
Dim destination As Range
Dim ln$, txt$

ChatFileNm = Application.GetOpenFilename(FileFilter:="Text Files (*.txt), >*.txt", Title:="Select Chat File To Be Opened")
If ChatFileNm = False Then Exit Sub
Set destination = Range("A1")
FF = FreeFile
Open ChatFileNm For Input As FF
Do Until EOF(FF)
    Line Input #FF, ln
    'Write the line in to the destination
    txt = txt & ln
Loop
'Release the lock on the file
Close FF

'Write to the sheet:
Dim lines
lines = Split(txt, Chr(10))
Range("A1").Resize(Ubound(lines)+1).Value = Application.Transpose(lines)

End Sub