我需要将Excel数据分割成单元格

我有一个电子表格查询数据源，并返回一个由230行逗号分隔的结果组成的数组。数据看起来像这样：我需要将Excel数据分割成单元格

Existing Data

我需要有所有这些逗号隔开的现在是在一个单元（列B）分割成单独的单元的值。每行通常有21个结果。所以结果应该是这样的：

Desired Result

上可以改变数据开始行，但通常开始各地的顶级行用于从它下面的数据显示结果80排。起点可以固定在120行（如果这使得脚本更容易），这将为未来的开发留下充足的空间。

我试着修改了我在这里找到的一些不同的解决方案，但都没有工作。任何帮助都非常感谢！

来源

2017-04-01 Steve

将逗号分隔的数据复制到记事本中，并使用find和replace将所有逗号替换为TAB。将其复制并粘贴回Excel，然后将这些值放入单独的单元格中。 – Gordon

只需使用“数据”>“文本到列”并在逗号分隔。无需将数据导出到记事本等。如果您希望vba解决方案遍历需要拆分的单元格并使用“拆分”功能并将该数组写回到工作表 – Tom

将'0,0'放入A1在空白工作表上，并通过TextToColumns，分隔符，逗号，完成。清除A1和B1。将来自其源的数据粘贴到A1中。它应该正确拆分。 – Jeeped

感谢所有帮助和指引正确的方向。这是我最终使用的：

Sub Expand_Array_On_New_Sheet 

' First check that new sheet name doesn't already exist, and create sheet 

    Sheet_name_to_create = Sheet10.Range("B1").Value 
    If WorksheetExists2(Sheet10.Range("B1")) Then 
     MsgBox "Sheet name already exists" 
    Exit Sub 
    Else 
    Sheets.Add After:=Sheets(1) 
    ActiveSheet.Name = Sheet_name_to_create 
    End If 

' Copy array data to new sheet 

    Worksheets("Lookup").Range("A11:B250").Copy 
    Range("A101").Select 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 
    Application.CutCopyMode = False 

' Expand Array Data into Columns and do some formatting 

    Range("B101:B350").Select 
    Selection.TextToColumns Destination:=Range("C101"), DataType:=xlDelimited, _ 
     TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _ 
     Semicolon:=False, Comma:=True, Space:=False, Other:=False, OtherChar _ 
     :=",", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1), Array(21, 1), Array(22, 1)), TrailingMinusNumbers:=True 
    Range("C100").Select 
    ActiveCell.FormulaR1C1 = "=R[-98]C[-1]-19" 
    Range("D100").Select 
    ActiveCell.FormulaR1C1 = "=RC[-1]+1" 
    Range("D100").Select 
    Selection.AutoFill Destination:=Range("D100:V100"), Type:=xlFillDefault 
    Range("W100").Select 
    ActiveCell.FormulaR1C1 = "Current" 
    Range("C100:W100").Select 
    With Selection.Interior 
     .Pattern = xlSolid 
     .PatternColorIndex = xlAutomatic 
     .ThemeColor = xlThemeColorDark1 
     .TintAndShade = -0.149998474074526 
     .PatternTintAndShade = 0 
    End With 
    Selection.Font.Bold = True 
    With Selection.Borders(xlEdgeBottom) 
     .LineStyle = xlContinuous 
     .ColorIndex = 0 
     .TintAndShade = 0 
     .Weight = xlMedium 
    End With 
    Selection.Borders(xlEdgeRight).LineStyle = xlNone 
    Selection.Borders(xlInsideVertical).LineStyle = xlNone 
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone 
    Range("B1").Select 
End Sub

它似乎运作良好。我遇到的问题是，如果数据集少于21个条目（大多数是21个，但不是全部），则最后一列数据结束于T或V列或某处。我需要最后一个条目始终在W列，并向后填充。我可能需要将它作为一个单独的问题进行搜索。

再次感谢您的帮助！

来源

2017-04-02 07:11:31 Steve

我没有完全测试这个，但也许你可以尝试这样的事情。该过程应循环遍历行并拆分B列中的值。

您需要将Set ws = ActiveWorkbook.Worksheets("Sheet1")中的“Sheet1”的名称更改为您正在使用的工作表的名称。

Public Sub SplitData() 

    Dim ws As Worksheet 
    Set ws = ActiveWorkbook.Worksheets("Sheet1") 

    Dim row As Integer 
    For row = 1 To ws.Range("A" & ws.Rows.Count).End(xlUp).row 

     Dim split_array() As String 
     split_array = Split(ws.Range("B" & row).Value, ",") 
     Dim split_str As Variant 
     Dim col As Integer 
     col = 3 
     For Each split_str In split_array 
      ws.Cells(row, col).Value = split_str 
      col = col + 1 
     Next split_str 

    Next row 

End Sub

我的纸张开始看起来像这样。