B列中的VBA逗号分隔数据与A列中的文本连接
我有一个VBA脚本，它用逗号将单元格中的数据分隔成单独的行，例如，如果单元格A1包含数据“a、B、C、D”，则该脚本将分隔该数据，使a位于一行，B位于下一行，等等（在指定的目标中） 我正在尝试更新此脚本，以便在逗号分隔的数据与每一新行连接之前单元格中的值，即如果单元格A1包含“Test”，而单元格B1包含“A、B、C、D”，则输出行应为“TestA”，然后下一行为“TestB”，以此类推 我被困在如何继续这项任务，任何输入都是有益的，我的VBA技能不是很好B列中的VBA逗号分隔数据与A列中的文本连接,vba,excel,Vba,Excel,我有一个VBA脚本，它用逗号将单元格中的数据分隔成单独的行，例如，如果单元格A1包含数据“a、B、C、D”，则该脚本将分隔该数据，使a位于一行，B位于下一行，等等（在指定的目标中） 我正在尝试更新此脚本，以便在逗号分隔的数据与每一新行连接之前单元格中的值，即如果单元格A1包含“Test”，而单元格B1包含“A、B、C、D”，则输出行应为“TestA”，然后下一行为“TestB”，以此类推 我被困在如何继续这项任务，任何输入都是有益的，我的VBA技能不是很好 Sub SplitAll() Dim
Sub SplitAll()
Dim xRg As Range
Dim xRg1 As Range
Dim xCell As Range
Dim I As Long
Dim xAddress As String
Dim xUpdate As Boolean
Dim xRet As Variant
On Error Resume Next
xAddress = Application.ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Please select a range", "Kutools for Excel", xAddress, , , , , 8)
Set xRg = Application.Intersect(xRg, xRg.Worksheet.UsedRange)
If xRg Is Nothing Then Exit Sub
If xRg.Columns.Count > 1 Then
MsgBox "You can't select multiple columns", , "Kutools for Excel"
Exit Sub
End If
Set xRg1 = Application.InputBox("Split to (single cell):", "Kutools for Excel", , , , , , 8)
Set xRg1 = xRg1.Range("A1")
If xRg1 Is Nothing Then Exit Sub
xUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
For Each xCell In xRg
xRet = Split(xCell.Value, ",")
xRg1.Worksheet.Range(xRg1.Offset(I, 0), xRg1.Offset(I + UBound(xRet, 1), 0)) = Application.WorksheetFunction.Transpose(xRet)
I = I + UBound(xRet, 1) + 1
Next
Application.ScreenUpdating = xUpdate
End Sub
Sub SplitAll()
Dim xRg As Range
Dim xRg1 As Range
Dim xCell As Range
Dim yCell As Range
Dim I As Long
Dim xAddress As String
Dim xUpdate As Boolean
Dim xRet As Variant
On Error Resume Next
xAddress = Application.ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Please select a range", "Kutools for Excel", xAddress, , , , , 8)
Set xRg = Application.Intersect(xRg, xRg.Worksheet.UsedRange)
If xRg Is Nothing Then Exit Sub
If xRg.Columns.Count > 1 Then
MsgBox "You can't select multiple columns", , "Kutools for Excel"
Exit Sub
End If
Set xRg1 = Application.InputBox("Split to (single cell):", "Kutools for Excel", , , , , , 8)
Set xRg1 = xRg1.Range("A1")
If xRg1 Is Nothing Then Exit Sub
xUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
For Each xCell In xRg
xRet = Split(xCell.Value, ",")
xRg1.Worksheet.Range(xRg1.Offset(I, 0), xRg1.Offset(I + UBound(xRet, 1), 0)) = Application.WorksheetFunction.Transpose(xRet)
For Each yCell In xRg1.Worksheet.Range(xRg1.Offset(I, 0), xRg1.Offset(I + UBound(xRet, 1), 0))
yCell.Value = yCell.Value & xCell.Offset(0, -1).Value
Next yCell
I = I + UBound(xRet, 1) + 1
Next
Application.ScreenUpdating = xUpdate
End Sub
Sub SplitAll()
Dim xRg As Range
Dim xRg1 As Range
Dim xCell As Range
Dim yCell As Range
Dim I As Long
Dim xAddress As String
Dim xUpdate As Boolean
Dim xRet As Variant
On Error Resume Next
xAddress = Application.ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Please select a range", "Kutools for Excel", xAddress, , , , , 8)
Set xRg = Application.Intersect(xRg, xRg.Worksheet.UsedRange)
If xRg Is Nothing Then Exit Sub
If xRg.Columns.Count > 1 Then
MsgBox "You can't select multiple columns", , "Kutools for Excel"
Exit Sub
End If
Set xRg1 = Application.InputBox("Split to (single cell):", "Kutools for Excel", , , , , , 8)
Set xRg1 = xRg1.Range("A1")
If xRg1 Is Nothing Then Exit Sub
xUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
For Each xCell In xRg
xRet = Split(xCell.Value, ",")
xRg1.Worksheet.Range(xRg1.Offset(I, 0), xRg1.Offset(I + UBound(xRet, 1), 0)) = Application.WorksheetFunction.Transpose(xRet)
For Each yCell In xRg1.Worksheet.Range(xRg1.Offset(I, 0), xRg1.Offset(I + UBound(xRet, 1), 0))
yCell.Value = yCell.Value & xCell.Offset(0, -1).Value
Next yCell
I = I + UBound(xRet, 1) + 1
Next
Application.ScreenUpdating = xUpdate
End Sub
这里有一种方法，不过您需要调整以添加提示用户选择范围等
Option Explicit
Public Sub test()
Dim arr(), i As Long, k As Long, tempArr() As String, outputArr(), counter As Long
ReDim outputArr(0 To 100000) '<size to something larger than may be expected
With ThisWorkbook.Worksheets("Sheet1")
arr = .Range("A1:B2").Value '<==prompt for range input instead here
For i = LBound(arr, 1) To UBound(arr, 1)
tempArr = Split(arr(i, 2), ",")
For k = LBound(tempArr) To UBound(tempArr)
outputArr(counter) = arr(i, 1) & tempArr(k)
counter = counter + 1
Next
Next
ReDim Preserve outputArr(0 To counter - 1)
.Range("C1").Resize(UBound(outputArr) + 1) = Application.WorksheetFunction.Transpose(outputArr)
End With
End Sub
选项显式
公共子测试（）
Dim arr（），i为长，k为长，tempArr（）为字符串，outputArr（），计数器为长
ReDim outputArr（0到100000）“这里有一种方法，不过您需要调整以添加提示用户选择范围等
Option Explicit
Public Sub test()
Dim arr(), i As Long, k As Long, tempArr() As String, outputArr(), counter As Long
ReDim outputArr(0 To 100000) '<size to something larger than may be expected
With ThisWorkbook.Worksheets("Sheet1")
arr = .Range("A1:B2").Value '<==prompt for range input instead here
For i = LBound(arr, 1) To UBound(arr, 1)
tempArr = Split(arr(i, 2), ",")
For k = LBound(tempArr) To UBound(tempArr)
outputArr(counter) = arr(i, 1) & tempArr(k)
counter = counter + 1
Next
Next
ReDim Preserve outputArr(0 To counter - 1)
.Range("C1").Resize(UBound(outputArr) + 1) = Application.WorksheetFunction.Transpose(outputArr)
End With
End Sub
选项显式
公共子测试（）
Dim arr（），i为长，k为长，tempArr（）为字符串，outputArr（），计数器为长
ReDim outputArr（0到100000）'如果您想在选择中有空行，在您的数据之后或行之间，添加此如果未UBound（xRet，1）=-1，则在上方为每个yCell添加一行…
并在下一个yCell
下方添加结束If
。这是因为当xCell.Value是一个空字符串（xRet=Split（xCell.Value，”，”）
）时，xRet的维度是（0到-1），所以它变得凌乱。这就解决了问题如果要在所选内容中有空行，请在数据后或行间添加此，如果未绑定（xRet，1）=-1，则在上方为每个yCell添加一行…
，并在下一个yCell
下方添加结束If
。这是因为当xCell.Value是一个空字符串（xRet=Split（xCell.Value，”，”）
）时，xRet的维度是（0到-1），所以它变得凌乱。这就解决了问题