vba Excel宏逐字读取文本文件并将每个单词写入同一列中的新单元格

Excel macro to read text file word by word and write every word to a new cell in the same column

提问by Vivek Ganapathy

I have a huge txt file with email ids delimited by ,(space), or ;, or a combination of these.

我有一个巨大的 txt 文件，其中的电子邮件 ID 由,（空格）、或;或这些的组合分隔。

I would like to separate these email ids and write them into new cells in just one column, row after row in the excel file.

我想将这些电子邮件 ID 分开，并将它们写入 Excel 文件中的一列、一行接一行的新单元格中。

Excel's delimited import is unable to show all ids as there are only 256 columns. And the number of words I have run into thousands. And is best suited to be inserted row by row into a new cell of the same column.

Excel 的分隔导入无法显示所有 ID，因为只有 256 列。我遇到的单词数已达数千。并且最适合逐行插入到同一列的新单元格中。

input text file looks like:

输入文本文件如下所示：

[email protected]; [email protected], [email protected], [email protected]

required output to excel file:

需要输出到excel文件：

[email protected]
[email protected]
[email protected] 
[email protected]

回答by Larry

Reference: http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/A_1480-How-to-Split-a-String-with-Multiple-Delimiters-in-VBA.html

参考：http: //www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/A_1480-How-to-Split-a-String-with-Multiple-Delimiters-in-VBA.html

Your question contains a few part

你的问题包含几个部分

1.Read txt file into a string (Excel has string limit) I have tried receiving an Error message "Out of String Space" , so I hope your "Huge" file isn't > 1G or something

1.Read txt file into a string (Excel has string limit) 我试过收到错误消息“Out of String Space”，所以我希望你的“巨大”文件不是> 1G或什么的

2.Split them by mutli-delimiters

2.用多分隔符分割它们

3.Output email per row

3.每行输出邮件

Sub Testing()
    Dim fname As String
    Dim sVal As String
    Dim count As Long
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet2") 'Replace Sheet1 with the output sheet name you want
    fname = "H:\My Documents\a.txt"   'Replace the path with your txt file path
    sVal = OpenTextFileToString2(fname)
    Dim tmp As Variant
    tmp = SplitMultiDelims(sVal, ",; ", True)   ' Place the 2nd argument with the list of delimiter you need to use
    count = 0
    For i = LBound(tmp, 1) To UBound(tmp, 1)

         count = count + 1
         ws.Cells(count, 1) = tmp(i)  'output on the first column

    Next i
End Sub    


Function OpenTextFileToString2(ByVal strFile As String) As String
' RB Smissaert - Author
Dim hFile As Long
hFile = FreeFile
Open strFile For Input As #hFile
OpenTextFileToString2 = Input$(LOF(hFile), hFile)
Close #hFile
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' SplitMultiDelims by alainbryden
' This function splits Text into an array of substrings, each substring
' delimited by any character in DelimChars. Only a single character
' may be a delimiter between two substrings, but DelimChars may
' contain any number of delimiter characters. It returns a single element
' array containing all of text if DelimChars is empty, or a 1 or greater
' element array if the Text is successfully split into substrings.
' If IgnoreConsecutiveDelimiters is true, empty array elements will not occur.
' If Limit greater than 0, the function will only split Text into 'Limit'
' array elements or less. The last element will contain the rest of Text.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function SplitMultiDelims(ByRef Text As String, ByRef DelimChars As String, _
        Optional ByVal IgnoreConsecutiveDelimiters As Boolean = False, _
        Optional ByVal Limit As Long = -1) As String()
    Dim ElemStart As Long, N As Long, M As Long, Elements As Long
    Dim lDelims As Long, lText As Long
    Dim Arr() As String

    lText = Len(Text)
    lDelims = Len(DelimChars)
    If lDelims = 0 Or lText = 0 Or Limit = 1 Then
        ReDim Arr(0 To 0)
        Arr(0) = Text
        SplitMultiDelims = Arr
        Exit Function
    End If
    ReDim Arr(0 To IIf(Limit = -1, lText - 1, Limit))

    Elements = 0: ElemStart = 1
    For N = 1 To lText
        If InStr(DelimChars, Mid(Text, N, 1)) Then
            Arr(Elements) = Mid(Text, ElemStart, N - ElemStart)
            If IgnoreConsecutiveDelimiters Then
                If Len(Arr(Elements)) > 0 Then Elements = Elements + 1
            Else
                Elements = Elements + 1
            End If
            ElemStart = N + 1
            If Elements + 1 = Limit Then Exit For
        End If
    Next N
    'Get the last token terminated by the end of the string into the array
    If ElemStart <= lText Then Arr(Elements) = Mid(Text, ElemStart)
    'Since the end of string counts as the terminating delimiter, if the last character
    'was also a delimiter, we treat the two as consecutive, and so ignore the last elemnent
    If IgnoreConsecutiveDelimiters Then If Len(Arr(Elements)) = 0 Then Elements = Elements - 1

    ReDim Preserve Arr(0 To Elements) 'Chop off unused array elements
    SplitMultiDelims = Arr
End Function

回答by SWa

Another way:

其它的办法：

Sub importText()

Const theFile As String = "Your File Path"
Dim rng

Open theFile For Input As #1
    rng = Application.Transpose(Filter(Split(Replace(Replace(Input(LOF(1), 1), " ", ""), ",", ";"), ";"), "@"))
Close

Sheets(1).Cells(1, 1).Resize(UBound(rng)).Value = rng

End Sub

EDITAs per the suggestion, I've update the above to deal with consecutive mixed delimiters (,;) so the above will allow for something like:

编辑根据建议，我已经更新了上面的内容以处理连续的混合分隔符 (,;)，因此上面的内容将允许以下内容：

[email protected]; [email protected], [email protected], [email protected];,;,; [email protected];; [email protected],,; [email protected], [email protected]