使用 VBA 将文本添加到 excel 中的列
text to column in excel using VBA
如果有人能告诉我如何将图像中显示的给定数据分成单独的列，我将非常感谢您的帮助。我试过使用固定长度，但您可以将前 2 到 3 个数字正确地分隔到列中，但第 4、5 个以后的数字将无法正确分隔到列中。我什至尝试重新调整分隔线，但是当您超出第 4 列和第 5 列时，分隔线会移动，您不能让完整的 phone 数字放在单列中。我也尝试了几种 VBA 技术，但 none 有效。
感谢您的帮助。
Como 2.1 壮举。非印刷品
我使用了我的 之一，更改了几行以大致满足您的需要。程序中的注释可能是错误的，但本质上它循环遍历此工作簿的 ActiveSheet 中的 A 列，并根据它找到的第一个不可打印字符拆分数据，并将结果放入新创建的工作 sheet 中。所以你的初期工作没有危险sheet。让我知道什么对你不起作用，这样我就可以制作一个不错的版本或自己做（评论太多了）。
'With Source
'.Title: Excel formula or SQL script that would put bulk text
' into individual cell
'.Type: Question
'.URL:
Option Explicit
'-------------------------------------------------------------------------------
Sub MultilineCellExtractor2() ' A work in progress
'-------------------------------------------------------------------------------
'Description
'Copies the contents of each cell of a specified COLUMN in a worksheet,
'skipping blank cells and converting multiple lines in cells each to a new
'cell, and returns the result in a COLUMN of a newly created worksheet.
'Arguments as constants
'cStrColumn
'The Column of the Initial Data in ThisWorkbook's ActiveSheet
'cStrColumnResult
'The Column of the Resulting Data in a Newly to be Created Worksheet
'cLoRow
'The First Row of the Resulting Data in the Newly Created Worksheet
'Returns
'A new worksheet with a column of the processed data.
'Usage
'Open the workbook to be processed. Go to VBE and insert a new module. Copy
'this script ('MultilineCellExtractor') and the function 'FirstNonPrintable'
'and paste them into the module. Edit the 'customize section' to fit your
'needs. Exit VBE and start the Run Macro Dialog (Play Button). DoubleClick or
'select 'MultilineCellExtractor' and click Run to execute.
'Remarks
'If there is no data in the column to be processed a message pops up (the only
'error handling done so far). If there are no multiline cells, the data is
'just copied while skipping the blanks.
'There can be no damage done using this script in the previously described way
'because the worksheet is only to be READ from, and the result is always
'pasted into a NEW worksheet.
'-------------------------------------------------------------------------------
'-- CUSTOMIZE BEGIN --------------------
Const cStrColumn As String = "A" 'Initial Data Column
Const cStrColumnResult As String = "A" 'Resulting Data Column
Const cLoRow As Long = 0 '0 to use the first row of the initial data range.
'-- CUSTOMIZE END ----------------------
'-------------------------------------------------------------------------------
Dim oRng As Range 'Initial Colum, Initial Range, Resulting Range
Dim arrRng As Variant 'Array Containing the Initial Data Range (Column)
Dim arrSplit As Variant 'Array Containing the Cell Lines
Dim arrData() As Variant 'Array Containing the Resulting Data Range (Column)
Dim loRow1 As Long 'First Row of the Initial Data Range (Column)
Dim loRow2 As Long 'Last Row of the Initial Data Range (Column)
Dim loRowResult As Long 'First Row of the Resulting Data Range (Column)
Dim loRng As Long 'Initial Array Rows Counter
Dim iSplit As Integer 'Multiline Cell Lines Counter
Dim loData As Long 'Resulting Array(Range) Rows Calculator and Counter
Dim strRng As String 'Initial Data Reader: Shortcut for arrRng(loRng, 1).
Dim str1 As String 'Debug String Writer
Dim lo1 As Long 'Debug String Array Data Counter
'-------------------------------------------------------------------------------
'Column of Initial Data
'Needed to calculate first and last rows of data.
Set oRng = ThisWorkbook.ActiveSheet.Range(cStrColumn & ":" & cStrColumn)
'First Row Containing Data
On Error Resume Next
loRow1 = oRng.Find(What:="*", After:=Cells(Rows.Count, cStrColumn), _
LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext).Row
If Err Then
MsgBox "You have probably selected a column with no data."
GoTo ProcedureExit
End If
'Last Row Containing Data
loRow2 = oRng.Find(What:="*", After:=Cells(1, cStrColumn), _
LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'Calculate Initial Range
Set oRng = ThisWorkbook.ActiveSheet.Range(Cells(loRow1, cStrColumn), _
Cells(loRow2, cStrColumn))
' str1 = "Calculate Initial Range (Results):"
' str1 = str1 & vbCrLf & Space(2) & "loRow1 = " & loRow1
' str1 = str1 & vbCrLf & Space(2) & "loRow2 = " & loRow2
' str1 = str1 & vbCrLf & Space(2) & "oRng.Address: " & oRng.Address
' Debug.Print str1 & vbCrLf
'Paste range into array
arrRng = oRng
Set oRng = Nothing 'Release the variable, initial data is in arrRng.
' str1 = "arrRng Contents:"
' For lo1 = LBound(arrRng) To UBound(arrRng)
' str1 = str1 & vbCrLf & Space(2) & lo1 & ". " & arrRng(lo1, 1)
' Next
' Debug.Print str1 & vbCrLf
'-------------------------------------------------------------------------------
'Now arrays are taking over
'***
Dim iData As Integer
'Count data in arrRng to calculate size of arrData.
For loRng = LBound(arrRng) To UBound(arrRng)
strRng = arrRng(loRng, 1)
If strRng <> "" Then 'Not empty cell, continue.
If FirstNonPrintable(strRng) > 0 Then 'Non printable character found.
'Splitting arrSplit by 'FirstNonPrintable'
arrSplit = Split(strRng, Chr(FirstNonPrintable(strRng)))
'***
If iData < UBound(arrSplit) + 1 Then
'***
iData = UBound(arrSplit) + 1
'***
End If
loData = loData + 1 '+ 1 i.e. arrSplit is 0-based.
Else 'Nonprintable character not found.
loData = loData + 1
End If
' Else 'Empty cell, do nothing.
End If
Next
'Redeclare arrData using the result of the counting (loData).
ReDim Preserve arrData(1 To loData, 1 To iData)
'Reset counter for counting.
loData = 0
iData = 0
'Read data from arrRng and write to array.
For loRng = LBound(arrRng) To UBound(arrRng)
strRng = arrRng(loRng, 1)
If strRng <> "" Then 'Not empty cell, continue.
If FirstNonPrintable(strRng) > 0 Then 'Non printable character found.
'Splitting arrSplit by 'FirstNonPrintable'
arrSplit = Split(strRng, Chr(FirstNonPrintable(strRng)))
'
str1 = "arrSplit Contents:"
For lo1 = LBound(arrSplit) To UBound(arrSplit)
str1 = str1 & vbCrLf & Space(2) & lo1 + 1 & ". " & arrSplit(lo1)
Next
Debug.Print str1 & vbCrLf
loData = loData + 1
'Writing arrSplit data to arrData.
For iSplit = LBound(arrSplit) To UBound(arrSplit)
arrData(loData, iSplit + 1) = arrSplit(iSplit)
Next
Erase arrSplit 'Is repeatedly newly created to write data to arrData.
Else 'Nonprintable character not found.
loData = loData + 1
arrData(loData, 1) = strRng
End If
' Else 'Empty cell, do nothing.
End If
Next
Erase arrRng 'No longer needed, resulting data is in arrData.
'
Dim i1 As Integer
str1 = "arrData Contents:"
For lo1 = LBound(arrData) To UBound(arrData)
For i1 = LBound(arrData, 2) To UBound(arrData, 2)
str1 = str1 & vbCrLf & Space(2) & lo1 & ". " & arrData(lo1, i1)
Next
Next
Debug.Print str1
'
'-------------------------------------------------------------------------------
'Return data in new worksheet
'Calculate the first row of data in the resulting worksheet.
If cLoRow > 0 Then
loRowResult = cLoRow 'Row as the constant in the 'customize section'.
Else
loRowResult = loRow1 'Same row as in the initial worksheet.
End If
'Add a new (resulting) worksheet positioned after the initial worksheet.
ThisWorkbook.Worksheets.Add _
After:=ActiveSheet 'The resulting worksheet is active now.
'Calculate the resulting range in the new worksheet.
Set oRng = ActiveSheet.Cells(loRowResult, cStrColumnResult). _
Resize(UBound(arrData), UBound(arrData, 2))
Debug.Print oRng.Address
'Paste data into the resulting range.
oRng = arrData
Erase arrData 'No longer needed, all data is in oRng.
'-------------------------------------------------------------------------------
ProcedureExit:
Set oRng = Nothing 'Release the variable, all data is in the worksheet.
End Sub
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
Function FirstNonPrintable(StringToClean As String, _
Optional Code0Position1String2 As Integer = 0) As Variant
'-------------------------------------------------------------------------------
'Description
'Finds the first character in a string that is different from the character
'at the same position in the cleaned version of the same string and returns
'its code, position or string.
'Arguments
'StringToClean (String)
'The string to clean.
'Code0Position1String2 (Integer)
'Returns for
'0, the character code (Asc) of the found character to be used with
'the Chr function.
'1, the position of the found character.
'2, the found character.
Dim strCleaned As String
Dim loLen As Long
strCleaned = WorksheetFunction.Clean(StringToClean)
If StringToClean = strCleaned Then Exit Function
For loLen = 1 To Len(StringToClean)
If Mid(StringToClean, loLen, 1) <> Mid(strCleaned, loLen, 1) Then
Select Case Code0Position1String2
Case 0
FirstNonPrintable = Asc(Mid(StringToClean, loLen, 1))
Case 1
FirstNonPrintable = loLen
Case 2
FirstNonPrintable = Mid(StringToClean, loLen, 1)
End Select
Exit Function
End If
Next
End Function
'-------------------------------------------------------------------------------
这是您发布的 link 中的文件：
这是程序运行s:
后新作品sheet的结果
您说过将值放入单独的列。 sheet 上有 120 行不是空白，包括其中带有 phone 的行。在 新创建的结果 sheet 中有 120 行，数据被分成列。现在，如果你能向我解释输出有什么问题，这样我就可以修复它。顺便说一句，无论有多少空行，程序都会 运行 直到列的末尾。只有内存不足才会崩溃。
'With Source
'.Title: Excel formula or SQL script that would put bulk text
' into individual cell
'.Type: Question
'.URL:
Option Explicit
'-------------------------------------------------------------------------------
Sub MultilineCellExtractor()
'-------------------------------------------------------------------------------
'Description
'Copies the contents of each cell of a specified COLUMN in a worksheet,
'skipping blank cells and converting multiple lines in cells each to a new
'cell, and returns the result in a COLUMN of a newly created worksheet.
'Arguments as constants
'cStrColumn
'The Column of the Initial Data in ThisWorkbook's ActiveSheet
'cStrColumnResult
'The Column of the Resulting Data in a Newly to be Created Worksheet
'cLoRow
'The First Row of the Resulting Data in the Newly Created Worksheet
'Returns
'A new worksheet with a column of the processed data.
'Usage
'Open the workbook to be processed. Go to VBE and insert a new module. Copy
'this script ('MultilineCellExtractor') and the function 'FirstNonPrintable'
'and paste them into the module. Edit the 'customize section' to fit your
'needs. Exit VBE and start the Run Macro Dialog (Play Button). DoubleClick or
'select 'MultilineCellExtractor' and click Run to execute.
'Remarks
'If there is no data in the column to be processed a message pops up (the only
'error handling done so far). If there are no multiline cells, the data is
'just copied while skipping the blanks.
'There can be no damage done using this script in the previously described way
'because the worksheet is only to be READ from, and the result is always
'pasted into a NEW worksheet.
'-------------------------------------------------------------------------------
'-- CUSTOMIZE BEGIN --------------------
Const cStrColumn As String = "A" 'Initial Data Column
Const cStrColumnResult As String = "A" 'Resulting Data Column
Const cLoRow As Long = 0 '0 to use the first row of the initial data range.
'-- CUSTOMIZE END ----------------------
'-------------------------------------------------------------------------------
Dim oRng As Range 'Initial Colum, Initial Range, Resulting Range
Dim arrRng As Variant 'Array Containing the Initial Data Range (Column)
Dim arrSplit As Variant 'Array Containing the Cell Lines
Dim arrData() As Variant 'Array Containing the Resulting Data Range (Column)
Dim loRow1 As Long 'First Row of the Initial Data Range (Column)
Dim loRow2 As Long 'Last Row of the Initial Data Range (Column)
Dim loRowResult As Long 'First Row of the Resulting Data Range (Column)
Dim loRng As Long 'Initial Array Rows Counter
Dim iSplit As Integer 'Multiline Cell Lines Counter
Dim loData As Long 'Resulting Array(Range) Rows Calculator and Counter
Dim strRng As String 'Initial Data Reader: Shortcut for arrRng(loRng, 1).
Dim str1 As String 'Debug String Writer
Dim lo1 As Long 'Debug String Array Data Counter
'-------------------------------------------------------------------------------
'Column of Initial Data
'Needed to calculate first and last rows of data.
Set oRng = ThisWorkbook.ActiveSheet.Range(cStrColumn & ":" & cStrColumn)
'First Row Containing Data
On Error Resume Next
loRow1 = oRng.Find(What:="*", After:=Cells(Rows.Count, cStrColumn), _
LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext).Row
If Err Then
MsgBox "You have probably selected a column with no data."
GoTo ProcedureExit
End If
'Last Row Containing Data
loRow2 = oRng.Find(What:="*", After:=Cells(1, cStrColumn), _
LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'Calculate Initial Range
Set oRng = ThisWorkbook.ActiveSheet.Range(Cells(loRow1, cStrColumn), _
Cells(loRow2, cStrColumn))
' str1 = "Calculate Initial Range (Results):"
' str1 = str1 & vbCrLf & Space(2) & "loRow1 = " & loRow1
' str1 = str1 & vbCrLf & Space(2) & "loRow2 = " & loRow2
' str1 = str1 & vbCrLf & Space(2) & "oRng.Address: " & oRng.Address
' Debug.Print str1 & vbCrLf
'Paste range into array
arrRng = oRng
Set oRng = Nothing 'Release the variable, initial data is in arrRng.
' str1 = "arrRng Contents:"
' For lo1 = LBound(arrRng) To UBound(arrRng)
' str1 = str1 & vbCrLf & Space(2) & lo1 & ". " & arrRng(lo1, 1)
' Next
' Debug.Print str1 & vbCrLf
'-------------------------------------------------------------------------------
'Now arrays are taking over
'***
Dim iData As Integer
'Count data in arrRng to calculate size of arrData.
For loRng = LBound(arrRng) To UBound(arrRng)
strRng = arrRng(loRng, 1)
' If strRng <> "" Then 'Not empty cell, continue.
If FirstNonPrintable(strRng) > 0 Then 'Non printable character found.
'Splitting arrSplit by 'FirstNonPrintable'
arrSplit = Split(strRng, Chr(FirstNonPrintable(strRng)))
'***
If iData < UBound(arrSplit) + 1 Then
'***
iData = UBound(arrSplit) + 1
'***
End If
loData = loData + 1 '+ 1 i.e. arrSplit is 0-based.
Else 'Nonprintable character not found.
loData = loData + 1
End If
' Else 'Empty cell, do nothing.
' End If
Next
'Redeclare arrData using the result of the counting (loData).
ReDim Preserve arrData(1 To loData, 1 To iData)
'Reset counter for counting.
loData = 0
iData = 0
'Read data from arrRng and write to array.
For loRng = LBound(arrRng) To UBound(arrRng)
strRng = arrRng(loRng, 1)
' If strRng <> "" Then 'Not empty cell, continue.
If FirstNonPrintable(strRng) > 0 Then 'Non printable character found.
'Splitting arrSplit by 'FirstNonPrintable'
arrSplit = Split(strRng, Chr(FirstNonPrintable(strRng)))
'
str1 = "arrSplit Contents:"
For lo1 = LBound(arrSplit) To UBound(arrSplit)
str1 = str1 & vbCrLf & Space(2) & lo1 + 1 & ". " & arrSplit(lo1)
Next
Debug.Print str1 & vbCrLf
loData = loData + 1
'Writing arrSplit data to arrData.
For iSplit = LBound(arrSplit) To UBound(arrSplit)
arrData(loData, iSplit + 1) = arrSplit(iSplit)
Next
Erase arrSplit 'Is repeatedly newly created to write data to arrData.
Else 'Nonprintable character not found.
loData = loData + 1
arrData(loData, 1) = strRng
End If
' Else 'Empty cell, do nothing.
' End If
Next
Erase arrRng 'No longer needed, resulting data is in arrData.
'
Dim i1 As Integer
str1 = "arrData Contents:"
For lo1 = LBound(arrData) To UBound(arrData)
For i1 = LBound(arrData, 2) To UBound(arrData, 2)
str1 = str1 & vbCrLf & Space(2) & lo1 & ". " & arrData(lo1, i1)
Next
Next
Debug.Print str1
'
'-------------------------------------------------------------------------------
'Return data in new worksheet
'Calculate the first row of data in the resulting worksheet.
If cLoRow > 0 Then
loRowResult = cLoRow 'Row as the constant in the 'customize section'.
Else
loRowResult = loRow1 'Same row as in the initial worksheet.
End If
'Add a new (resulting) worksheet positioned after the initial worksheet.
ThisWorkbook.Worksheets.Add _
After:=ActiveSheet 'The resulting worksheet is active now.
'Calculate the resulting range in the new worksheet.
Set oRng = ActiveSheet.Cells(loRowResult, cStrColumnResult). _
Resize(UBound(arrData), UBound(arrData, 2))
Debug.Print oRng.Address
'Paste data into the resulting range.
oRng = arrData
Erase arrData 'No longer needed, all data is in oRng.
'-------------------------------------------------------------------------------
ProcedureExit:
Set oRng = Nothing 'Release the variable, all data is in the worksheet.
End Sub
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
Function FirstNonPrintable(StringToClean As String, _
Optional Code0Position1String2 As Integer = 0) As Variant
'-------------------------------------------------------------------------------
'Description
'Finds the first character in a string that is different from the character
'at the same position in the cleaned version of the same string and returns
'its code, position or string.
'Arguments
'StringToClean (String)
'The string to clean.
'Code0Position1String2 (Integer)
'Returns for
'0, the character code (Asc) of the found character to be used with
'the Chr function.
'1, the position of the found character.
'2, the found character.
Dim strCleaned As String
Dim loLen As Long
strCleaned = WorksheetFunction.Clean(StringToClean)
If StringToClean = strCleaned Then Exit Function
For loLen = 1 To Len(StringToClean)
If Mid(StringToClean, loLen, 1) <> Mid(strCleaned, loLen, 1) Then
Select Case Code0Position1String2
Case 0
FirstNonPrintable = Asc(Mid(StringToClean, loLen, 1))
Case 1
FirstNonPrintable = loLen
Case 2
FirstNonPrintable = Mid(StringToClean, loLen, 1)
End Select
Exit Function
End If
Next
End Function
'-------------------------------------------------------------------------------
今天的结果应该就是您要找的。
如果有人能告诉我如何将图像中显示的给定数据分成单独的列，我将非常感谢您的帮助。我试过使用固定长度，但您可以将前 2 到 3 个数字正确地分隔到列中，但第 4、5 个以后的数字将无法正确分隔到列中。我什至尝试重新调整分隔线，但是当您超出第 4 列和第 5 列时，分隔线会移动，您不能让完整的 phone 数字放在单列中。我也尝试了几种 VBA 技术，但 none 有效。
感谢您的帮助。
Como 2.1 壮举。非印刷品
我使用了我的
'With Source
'.Title: Excel formula or SQL script that would put bulk text
' into individual cell
'.Type: Question
'.URL:
Option Explicit
'-------------------------------------------------------------------------------
Sub MultilineCellExtractor2() ' A work in progress
'-------------------------------------------------------------------------------
'Description
'Copies the contents of each cell of a specified COLUMN in a worksheet,
'skipping blank cells and converting multiple lines in cells each to a new
'cell, and returns the result in a COLUMN of a newly created worksheet.
'Arguments as constants
'cStrColumn
'The Column of the Initial Data in ThisWorkbook's ActiveSheet
'cStrColumnResult
'The Column of the Resulting Data in a Newly to be Created Worksheet
'cLoRow
'The First Row of the Resulting Data in the Newly Created Worksheet
'Returns
'A new worksheet with a column of the processed data.
'Usage
'Open the workbook to be processed. Go to VBE and insert a new module. Copy
'this script ('MultilineCellExtractor') and the function 'FirstNonPrintable'
'and paste them into the module. Edit the 'customize section' to fit your
'needs. Exit VBE and start the Run Macro Dialog (Play Button). DoubleClick or
'select 'MultilineCellExtractor' and click Run to execute.
'Remarks
'If there is no data in the column to be processed a message pops up (the only
'error handling done so far). If there are no multiline cells, the data is
'just copied while skipping the blanks.
'There can be no damage done using this script in the previously described way
'because the worksheet is only to be READ from, and the result is always
'pasted into a NEW worksheet.
'-------------------------------------------------------------------------------
'-- CUSTOMIZE BEGIN --------------------
Const cStrColumn As String = "A" 'Initial Data Column
Const cStrColumnResult As String = "A" 'Resulting Data Column
Const cLoRow As Long = 0 '0 to use the first row of the initial data range.
'-- CUSTOMIZE END ----------------------
'-------------------------------------------------------------------------------
Dim oRng As Range 'Initial Colum, Initial Range, Resulting Range
Dim arrRng As Variant 'Array Containing the Initial Data Range (Column)
Dim arrSplit As Variant 'Array Containing the Cell Lines
Dim arrData() As Variant 'Array Containing the Resulting Data Range (Column)
Dim loRow1 As Long 'First Row of the Initial Data Range (Column)
Dim loRow2 As Long 'Last Row of the Initial Data Range (Column)
Dim loRowResult As Long 'First Row of the Resulting Data Range (Column)
Dim loRng As Long 'Initial Array Rows Counter
Dim iSplit As Integer 'Multiline Cell Lines Counter
Dim loData As Long 'Resulting Array(Range) Rows Calculator and Counter
Dim strRng As String 'Initial Data Reader: Shortcut for arrRng(loRng, 1).
Dim str1 As String 'Debug String Writer
Dim lo1 As Long 'Debug String Array Data Counter
'-------------------------------------------------------------------------------
'Column of Initial Data
'Needed to calculate first and last rows of data.
Set oRng = ThisWorkbook.ActiveSheet.Range(cStrColumn & ":" & cStrColumn)
'First Row Containing Data
On Error Resume Next
loRow1 = oRng.Find(What:="*", After:=Cells(Rows.Count, cStrColumn), _
LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext).Row
If Err Then
MsgBox "You have probably selected a column with no data."
GoTo ProcedureExit
End If
'Last Row Containing Data
loRow2 = oRng.Find(What:="*", After:=Cells(1, cStrColumn), _
LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'Calculate Initial Range
Set oRng = ThisWorkbook.ActiveSheet.Range(Cells(loRow1, cStrColumn), _
Cells(loRow2, cStrColumn))
' str1 = "Calculate Initial Range (Results):"
' str1 = str1 & vbCrLf & Space(2) & "loRow1 = " & loRow1
' str1 = str1 & vbCrLf & Space(2) & "loRow2 = " & loRow2
' str1 = str1 & vbCrLf & Space(2) & "oRng.Address: " & oRng.Address
' Debug.Print str1 & vbCrLf
'Paste range into array
arrRng = oRng
Set oRng = Nothing 'Release the variable, initial data is in arrRng.
' str1 = "arrRng Contents:"
' For lo1 = LBound(arrRng) To UBound(arrRng)
' str1 = str1 & vbCrLf & Space(2) & lo1 & ". " & arrRng(lo1, 1)
' Next
' Debug.Print str1 & vbCrLf
'-------------------------------------------------------------------------------
'Now arrays are taking over
'***
Dim iData As Integer
'Count data in arrRng to calculate size of arrData.
For loRng = LBound(arrRng) To UBound(arrRng)
strRng = arrRng(loRng, 1)
If strRng <> "" Then 'Not empty cell, continue.
If FirstNonPrintable(strRng) > 0 Then 'Non printable character found.
'Splitting arrSplit by 'FirstNonPrintable'
arrSplit = Split(strRng, Chr(FirstNonPrintable(strRng)))
'***
If iData < UBound(arrSplit) + 1 Then
'***
iData = UBound(arrSplit) + 1
'***
End If
loData = loData + 1 '+ 1 i.e. arrSplit is 0-based.
Else 'Nonprintable character not found.
loData = loData + 1
End If
' Else 'Empty cell, do nothing.
End If
Next
'Redeclare arrData using the result of the counting (loData).
ReDim Preserve arrData(1 To loData, 1 To iData)
'Reset counter for counting.
loData = 0
iData = 0
'Read data from arrRng and write to array.
For loRng = LBound(arrRng) To UBound(arrRng)
strRng = arrRng(loRng, 1)
If strRng <> "" Then 'Not empty cell, continue.
If FirstNonPrintable(strRng) > 0 Then 'Non printable character found.
'Splitting arrSplit by 'FirstNonPrintable'
arrSplit = Split(strRng, Chr(FirstNonPrintable(strRng)))
'
str1 = "arrSplit Contents:"
For lo1 = LBound(arrSplit) To UBound(arrSplit)
str1 = str1 & vbCrLf & Space(2) & lo1 + 1 & ". " & arrSplit(lo1)
Next
Debug.Print str1 & vbCrLf
loData = loData + 1
'Writing arrSplit data to arrData.
For iSplit = LBound(arrSplit) To UBound(arrSplit)
arrData(loData, iSplit + 1) = arrSplit(iSplit)
Next
Erase arrSplit 'Is repeatedly newly created to write data to arrData.
Else 'Nonprintable character not found.
loData = loData + 1
arrData(loData, 1) = strRng
End If
' Else 'Empty cell, do nothing.
End If
Next
Erase arrRng 'No longer needed, resulting data is in arrData.
'
Dim i1 As Integer
str1 = "arrData Contents:"
For lo1 = LBound(arrData) To UBound(arrData)
For i1 = LBound(arrData, 2) To UBound(arrData, 2)
str1 = str1 & vbCrLf & Space(2) & lo1 & ". " & arrData(lo1, i1)
Next
Next
Debug.Print str1
'
'-------------------------------------------------------------------------------
'Return data in new worksheet
'Calculate the first row of data in the resulting worksheet.
If cLoRow > 0 Then
loRowResult = cLoRow 'Row as the constant in the 'customize section'.
Else
loRowResult = loRow1 'Same row as in the initial worksheet.
End If
'Add a new (resulting) worksheet positioned after the initial worksheet.
ThisWorkbook.Worksheets.Add _
After:=ActiveSheet 'The resulting worksheet is active now.
'Calculate the resulting range in the new worksheet.
Set oRng = ActiveSheet.Cells(loRowResult, cStrColumnResult). _
Resize(UBound(arrData), UBound(arrData, 2))
Debug.Print oRng.Address
'Paste data into the resulting range.
oRng = arrData
Erase arrData 'No longer needed, all data is in oRng.
'-------------------------------------------------------------------------------
ProcedureExit:
Set oRng = Nothing 'Release the variable, all data is in the worksheet.
End Sub
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
Function FirstNonPrintable(StringToClean As String, _
Optional Code0Position1String2 As Integer = 0) As Variant
'-------------------------------------------------------------------------------
'Description
'Finds the first character in a string that is different from the character
'at the same position in the cleaned version of the same string and returns
'its code, position or string.
'Arguments
'StringToClean (String)
'The string to clean.
'Code0Position1String2 (Integer)
'Returns for
'0, the character code (Asc) of the found character to be used with
'the Chr function.
'1, the position of the found character.
'2, the found character.
Dim strCleaned As String
Dim loLen As Long
strCleaned = WorksheetFunction.Clean(StringToClean)
If StringToClean = strCleaned Then Exit Function
For loLen = 1 To Len(StringToClean)
If Mid(StringToClean, loLen, 1) <> Mid(strCleaned, loLen, 1) Then
Select Case Code0Position1String2
Case 0
FirstNonPrintable = Asc(Mid(StringToClean, loLen, 1))
Case 1
FirstNonPrintable = loLen
Case 2
FirstNonPrintable = Mid(StringToClean, loLen, 1)
End Select
Exit Function
End If
Next
End Function
'-------------------------------------------------------------------------------
这是您发布的 link 中的文件：
这是程序运行s:
后新作品sheet的结果您说过将值放入单独的列。 sheet 上有 120 行不是空白，包括其中带有 phone 的行。在 新创建的结果 sheet 中有 120 行，数据被分成列。现在，如果你能向我解释输出有什么问题，这样我就可以修复它。顺便说一句，无论有多少空行，程序都会 运行 直到列的末尾。只有内存不足才会崩溃。
'With Source
'.Title: Excel formula or SQL script that would put bulk text
' into individual cell
'.Type: Question
'.URL:
Option Explicit
'-------------------------------------------------------------------------------
Sub MultilineCellExtractor()
'-------------------------------------------------------------------------------
'Description
'Copies the contents of each cell of a specified COLUMN in a worksheet,
'skipping blank cells and converting multiple lines in cells each to a new
'cell, and returns the result in a COLUMN of a newly created worksheet.
'Arguments as constants
'cStrColumn
'The Column of the Initial Data in ThisWorkbook's ActiveSheet
'cStrColumnResult
'The Column of the Resulting Data in a Newly to be Created Worksheet
'cLoRow
'The First Row of the Resulting Data in the Newly Created Worksheet
'Returns
'A new worksheet with a column of the processed data.
'Usage
'Open the workbook to be processed. Go to VBE and insert a new module. Copy
'this script ('MultilineCellExtractor') and the function 'FirstNonPrintable'
'and paste them into the module. Edit the 'customize section' to fit your
'needs. Exit VBE and start the Run Macro Dialog (Play Button). DoubleClick or
'select 'MultilineCellExtractor' and click Run to execute.
'Remarks
'If there is no data in the column to be processed a message pops up (the only
'error handling done so far). If there are no multiline cells, the data is
'just copied while skipping the blanks.
'There can be no damage done using this script in the previously described way
'because the worksheet is only to be READ from, and the result is always
'pasted into a NEW worksheet.
'-------------------------------------------------------------------------------
'-- CUSTOMIZE BEGIN --------------------
Const cStrColumn As String = "A" 'Initial Data Column
Const cStrColumnResult As String = "A" 'Resulting Data Column
Const cLoRow As Long = 0 '0 to use the first row of the initial data range.
'-- CUSTOMIZE END ----------------------
'-------------------------------------------------------------------------------
Dim oRng As Range 'Initial Colum, Initial Range, Resulting Range
Dim arrRng As Variant 'Array Containing the Initial Data Range (Column)
Dim arrSplit As Variant 'Array Containing the Cell Lines
Dim arrData() As Variant 'Array Containing the Resulting Data Range (Column)
Dim loRow1 As Long 'First Row of the Initial Data Range (Column)
Dim loRow2 As Long 'Last Row of the Initial Data Range (Column)
Dim loRowResult As Long 'First Row of the Resulting Data Range (Column)
Dim loRng As Long 'Initial Array Rows Counter
Dim iSplit As Integer 'Multiline Cell Lines Counter
Dim loData As Long 'Resulting Array(Range) Rows Calculator and Counter
Dim strRng As String 'Initial Data Reader: Shortcut for arrRng(loRng, 1).
Dim str1 As String 'Debug String Writer
Dim lo1 As Long 'Debug String Array Data Counter
'-------------------------------------------------------------------------------
'Column of Initial Data
'Needed to calculate first and last rows of data.
Set oRng = ThisWorkbook.ActiveSheet.Range(cStrColumn & ":" & cStrColumn)
'First Row Containing Data
On Error Resume Next
loRow1 = oRng.Find(What:="*", After:=Cells(Rows.Count, cStrColumn), _
LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext).Row
If Err Then
MsgBox "You have probably selected a column with no data."
GoTo ProcedureExit
End If
'Last Row Containing Data
loRow2 = oRng.Find(What:="*", After:=Cells(1, cStrColumn), _
LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'Calculate Initial Range
Set oRng = ThisWorkbook.ActiveSheet.Range(Cells(loRow1, cStrColumn), _
Cells(loRow2, cStrColumn))
' str1 = "Calculate Initial Range (Results):"
' str1 = str1 & vbCrLf & Space(2) & "loRow1 = " & loRow1
' str1 = str1 & vbCrLf & Space(2) & "loRow2 = " & loRow2
' str1 = str1 & vbCrLf & Space(2) & "oRng.Address: " & oRng.Address
' Debug.Print str1 & vbCrLf
'Paste range into array
arrRng = oRng
Set oRng = Nothing 'Release the variable, initial data is in arrRng.
' str1 = "arrRng Contents:"
' For lo1 = LBound(arrRng) To UBound(arrRng)
' str1 = str1 & vbCrLf & Space(2) & lo1 & ". " & arrRng(lo1, 1)
' Next
' Debug.Print str1 & vbCrLf
'-------------------------------------------------------------------------------
'Now arrays are taking over
'***
Dim iData As Integer
'Count data in arrRng to calculate size of arrData.
For loRng = LBound(arrRng) To UBound(arrRng)
strRng = arrRng(loRng, 1)
' If strRng <> "" Then 'Not empty cell, continue.
If FirstNonPrintable(strRng) > 0 Then 'Non printable character found.
'Splitting arrSplit by 'FirstNonPrintable'
arrSplit = Split(strRng, Chr(FirstNonPrintable(strRng)))
'***
If iData < UBound(arrSplit) + 1 Then
'***
iData = UBound(arrSplit) + 1
'***
End If
loData = loData + 1 '+ 1 i.e. arrSplit is 0-based.
Else 'Nonprintable character not found.
loData = loData + 1
End If
' Else 'Empty cell, do nothing.
' End If
Next
'Redeclare arrData using the result of the counting (loData).
ReDim Preserve arrData(1 To loData, 1 To iData)
'Reset counter for counting.
loData = 0
iData = 0
'Read data from arrRng and write to array.
For loRng = LBound(arrRng) To UBound(arrRng)
strRng = arrRng(loRng, 1)
' If strRng <> "" Then 'Not empty cell, continue.
If FirstNonPrintable(strRng) > 0 Then 'Non printable character found.
'Splitting arrSplit by 'FirstNonPrintable'
arrSplit = Split(strRng, Chr(FirstNonPrintable(strRng)))
'
str1 = "arrSplit Contents:"
For lo1 = LBound(arrSplit) To UBound(arrSplit)
str1 = str1 & vbCrLf & Space(2) & lo1 + 1 & ". " & arrSplit(lo1)
Next
Debug.Print str1 & vbCrLf
loData = loData + 1
'Writing arrSplit data to arrData.
For iSplit = LBound(arrSplit) To UBound(arrSplit)
arrData(loData, iSplit + 1) = arrSplit(iSplit)
Next
Erase arrSplit 'Is repeatedly newly created to write data to arrData.
Else 'Nonprintable character not found.
loData = loData + 1
arrData(loData, 1) = strRng
End If
' Else 'Empty cell, do nothing.
' End If
Next
Erase arrRng 'No longer needed, resulting data is in arrData.
'
Dim i1 As Integer
str1 = "arrData Contents:"
For lo1 = LBound(arrData) To UBound(arrData)
For i1 = LBound(arrData, 2) To UBound(arrData, 2)
str1 = str1 & vbCrLf & Space(2) & lo1 & ". " & arrData(lo1, i1)
Next
Next
Debug.Print str1
'
'-------------------------------------------------------------------------------
'Return data in new worksheet
'Calculate the first row of data in the resulting worksheet.
If cLoRow > 0 Then
loRowResult = cLoRow 'Row as the constant in the 'customize section'.
Else
loRowResult = loRow1 'Same row as in the initial worksheet.
End If
'Add a new (resulting) worksheet positioned after the initial worksheet.
ThisWorkbook.Worksheets.Add _
After:=ActiveSheet 'The resulting worksheet is active now.
'Calculate the resulting range in the new worksheet.
Set oRng = ActiveSheet.Cells(loRowResult, cStrColumnResult). _
Resize(UBound(arrData), UBound(arrData, 2))
Debug.Print oRng.Address
'Paste data into the resulting range.
oRng = arrData
Erase arrData 'No longer needed, all data is in oRng.
'-------------------------------------------------------------------------------
ProcedureExit:
Set oRng = Nothing 'Release the variable, all data is in the worksheet.
End Sub
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
Function FirstNonPrintable(StringToClean As String, _
Optional Code0Position1String2 As Integer = 0) As Variant
'-------------------------------------------------------------------------------
'Description
'Finds the first character in a string that is different from the character
'at the same position in the cleaned version of the same string and returns
'its code, position or string.
'Arguments
'StringToClean (String)
'The string to clean.
'Code0Position1String2 (Integer)
'Returns for
'0, the character code (Asc) of the found character to be used with
'the Chr function.
'1, the position of the found character.
'2, the found character.
Dim strCleaned As String
Dim loLen As Long
strCleaned = WorksheetFunction.Clean(StringToClean)
If StringToClean = strCleaned Then Exit Function
For loLen = 1 To Len(StringToClean)
If Mid(StringToClean, loLen, 1) <> Mid(strCleaned, loLen, 1) Then
Select Case Code0Position1String2
Case 0
FirstNonPrintable = Asc(Mid(StringToClean, loLen, 1))
Case 1
FirstNonPrintable = loLen
Case 2
FirstNonPrintable = Mid(StringToClean, loLen, 1)
End Select
Exit Function
End If
Next
End Function
'-------------------------------------------------------------------------------
今天的结果应该就是您要找的。