Код VBA для разделения данных в диапазоне ячеек

Question

Я отредактировал этот вопрос, чтобы добавить код, который у меня уже есть.

Мне нужен код VBA Excel для разделения данных в ячейках.

Split Правило: 1- Всякий раз, когда вы нашли место «» раскол и поставить его в следующей колонке, затем 2- Loop к следующей строке и сделать то же самое, пока клетка не является пустым т.е. больше нет данных.

Пожалуйста, обратитесь к прилагаемому изображению, например: данные для разделения в столбце A, и результат будет указан в следующих столбцах.

Я пробовал код, приведенный ниже, и он выполняет эту работу, но не выполняет цикл в следующую строку. Можете ли вы отредактировать этот код, чтобы сделать его циклом в следующую строку и остановиться, когда больше нет данных i.e. Blank Cell.

Sub example() 
Dim text As String 
Dim a As Integer 
Dim name As Variant 
text = ActiveCell.Value 
name = Split(text, " ") 
For a = 0 To UBound(name) 
Cells(1, a + 1).Value = name(a) 
Next a 
End Sub 

Большое спасибо.

Answer 1

Вот как я бы этот подход, хотя решение @Darren Bartrup-Кук, кажется более простым

Dim ws As Worksheet 
Dim lastRow As Long 
Dim data As Range, dataList As Range 
Dim arrData, i 

Set ws = ThisWorkbook.Worksheets("YourWorksheetName") 
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 
Set dataList = ws.Range("A1").Resize(lastRow, 1) 

For Each data In dataList 
    arrData = Split(data.Value) 
    For i = LBound(arrData) To UBound(arrData) 
     ws.Cells(data.Row, i + 2).Value = arrData(i) 
    Next 
Next 

Update: Другая возможность заключается в том, чтобы использовать мой подход для того, чтобы динамически получить Использованный Range (с несколькими модификациями), а затем замените мой цикл For на подход Darren для выполнения Split. Вы бы в конечном итоге с чем-то вроде следующего

Sub Test() 

    Dim lastRow As Long 
    Dim dataList As Range 

    With ThisWorkbook.Worksheets("YourWorksheetName") 
     lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 
     Set dataList = .Range("A1").Resize(lastRow, 1) 
    End With 

    SplitText dataList 

End Sub 

Sub SplitText(MyRange As Range) 

    MyRange.TextToColumns Destination:=MyRange.Offset(, 1), DataType:=xlDelimited, _ 
     TextQualifier:=xlTextQualifierDoubleQuote, ConsecutiveDelimiter:=True, _ 
     Space:=True 

End Sub 

Update 2: Эта версия будет работать код для каждого листа в книге

Sub Test() 

    Dim lastRow As Long 
    Dim ws as Worksheet 
    Dim dataList As Range 

    For Each ws In ThisWorkbook.Worksheets 
     lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 
     Set dataList = ws.Range("A1").Resize(lastRow, 1) 
     SplitText dataList 
    Next 

End Sub 

Sub SplitText(MyRange As Range) 

    MyRange.TextToColumns Destination:=MyRange.Offset(, 1), DataType:=xlDelimited, _ 
     TextQualifier:=xlTextQualifierDoubleQuote, ConsecutiveDelimiter:=True, _ 
     Space:=True 

End Sub 

Answer 2

Я просто сделал быстрый и грязный пример. Он соответствует только вашему примеру и должен быть расширен, чтобы соответствовать нескольким случаям.

Public Sub spliting() 

Dim row As Integer 
Set ws = Sheets("sheet1") 
row = 1 
Dim TestArray As Variant 
With ws 
    Do 
     TestArray = split(CStr(.Cells(row, 1).Value)) 
     .Cells(row, 2) = TestArray(0) 
     .Cells(row, 3) = TestArray(1) 
     .Cells(row, 4) = TestArray(2) 
     row = row + 1 
    Loop Until row = 4 
End With 

End Sub 

Answer 3

Макрос запись показывает это при использовании TextToColumns:

Selection.TextToColumns Destination:=Range("B2"), DataType:=xlDelimited, _ 
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _ 
    Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _ 
    :=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True 

Замена Selection с выбранным диапазоном, и удаление некоторых параметров, которые имеют значение по умолчанию ложь вы можете использовать этот код, чтобы разделить значения в диапазоне A2:A4.

Sub Test() 

    SplitText ThisWorkbook.Worksheets("Sheet1").Range("A2:A4") 

End Sub 

Sub SplitText(MyRange As Range) 

    MyRange.TextToColumns Destination:=MyRange.Offset(, 1), DataType:=xlDelimited, _ 
     TextQualifier:=xlTextQualifierDoubleQuote, ConsecutiveDelimiter:=True, _ 
     Space:=True 

End Sub