Question

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

我想将这些电子邮件ID分开并将它们写入excel文件中一行一列的新列中。

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

输入文本文件如下：

abc@abc.com; xyx@xyc.com, ext@124.de, abcd@cycd.com

要求输出到excel文件：

abc@abc.com
xyx@xyc.com
ext@124.de 
abcd@cycd.com

Answer 1

参考：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

您的问题包含一些部分

1.将txt文件读入一个字符串（Excel有字符串限制）我试过收到错误消息“Out of String Space”，所以我希望你的“巨大”文件不是＆gt; 1G或其他什么

2.通过mutli-delimiters拆分它们

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

Answer 2

另一种方式：

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

修改根据建议，我更新了上面的内容以处理连续的混合分隔符（，;），所以上面的内容将允许：

abc@abc.com; xyx@xyc.com, ext@124.de, abcd@cycd.com;,;,; abc@abc.com;; xyx@xyc.com,,; ext@124.de, abcd@cycd.com

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

2 个答案: