Код возврата VBA и код заполнения

Question

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

Описание проблемы (в связи с диаграммой ниже): 1 *) В c, мне удалось отделить возвратные вагоны, что приводит к 2 *) теперь, когда каждая возвратная каретка имеет свою собственную строку, мне нужна колонка b и с обеих сторон должны быть заполнены вниз, как показано в результате 3 *)

1*)  b  c  e 
     y 1,2,3,4  y 
     z 5,6,7,8  z 



2*)  b c e 
     y 1 y 
      2 
      3 
      4 
     z 5 z 
      6 
      7 
      8 

3*)  b c e 
     y 1 y 
     y 2 y 
     y 3 y 
     y 4 y 
     z 5 z 
     z 6 z 
     z 7 z 
     z 8 z 

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

Sub InString() 

Dim rColumn As Range 'Set this to the column which needs to be worked through 
Dim lFirstRow As Long 
Dim lLastRow As Long 
Dim lRow As Long 'Difference between first and last row 
Dim lLFs As Long 
Dim rRow As Range 'This will be used to drag the fill down between rows 


Set rColumn = Columns("N") 
lFirstRow = 2 'Starting may need to be adjusted, if additional columns are added 
lLastRow = rColumn.Cells(Rows.Count).End(xlUp).Row 

For lRow = lLastRow To lFirstRow Step -1 
lLFs = Len(rColumn.Cells(lRow)) - Len(Replace(rColumn.Cells(lRow), vbLf, "")) 
If lLFs > 0 Then 
    rColumn.Cells(lRow + 1).Resize(lLFs).EntireRow.Insert shift:=xlShiftDown 'added EntireRow to before insert, to bring whole row down, instead of previous issue where only rColumn was shifted down. 
    rColumn.Cells(lRow).Resize(lLFs + 1).Value = Application.Transpose(Split(rColumn.Cells(lRow), vbLf)) 
    End If 
Next lRow 

Конец Sub

Спасибо,

Answer 1

Я просто добавил петлю в конце ищет пробелы -

Sub InString() 

Dim rColumn As Range 'Set this to the column which needs to be worked through 
Dim lFirstRow As Long 
Dim lLastRow As Long 
Dim lRow As Long 'Difference between first and last row 
Dim lLFs As Long 
Dim rRow As Range 'This will be used to drag the fill down between rows 
Dim strVal As String 

Set rColumn = Columns("N") 
lFirstRow = 2 'Starting may need to be adjusted, if additional columns are added 
lLastRow = rColumn.Cells(Rows.Count).End(xlUp).row 

For lRow = lLastRow To lFirstRow Step -1 
lLFs = Len(rColumn.Cells(lRow)) - Len(Replace(rColumn.Cells(lRow), vbLf, "")) 
If lLFs > 0 Then 
    rColumn.Cells(lRow + 1).Resize(lLFs).EntireRow.Insert shift:=xlShiftDown 'added EntireRow to before insert, to bring whole row down, instead of previous issue where only rColumn was shifted down. 
    rColumn.Cells(lRow).Resize(lLFs + 1).Value = Application.Transpose(Split(rColumn.Cells(lRow), vbLf)) 
    End If 
Next lRow 

lLastRow = rColumn.Cells(Rows.Count).End(xlUp).row 
Dim rColNum As Integer 
rColNum = rColumn.Column 
For i = 2 To lLastRow 
    If Cells(i, rColNum - 1) = "" Then 
    Cells(i, rColNum - 1) = Cells(i - 1, rColNum - 1) 
    Cells(i, rColNum + 1) = Cells(i - 1, rColNum + 1) 
    End If 
Next 
End Sub 

В основном эта часть -

For i = 2 To lLastRow 
    If Cells(i, rColNum - 1) = "" Then 
    Cells(i, rColNum - 1) = Cells(i - 1, rColNum - 1) 
    Cells(i, rColNum + 1) = Cells(i - 1, rColNum + 1) 
    End If 
Next 

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

Для расширения, вы могли бы тогда сказать

if Cells(i, rColNum - 1) = "" Then 
    Cells(i, rColNum - 1) = Cells(i - 1, rColNum - 1) 
    Cells(i, rColNum + 1) = Cells(i - 1, rColNum + 1) 
    Cells(i, rColNum - 2) = Cells(i - 1, rColNum - 2) 
    Cells(i, rColNum + 2) = Cells(i - 1, rColNum + 2) 
    End If 

Если вы хотите, чтобы покрыть соседние две колонки по обе стороны от rcolumn.

Answer 2

Предполагая, что ваши входные данные в колонках B, D and E (как ваша схема предполагает), то это работа, которую я думаю:

Sub OrderData() 
    Dim inputData As Range, temp() As Variant, splitData As Variant, i As Integer, j As Integer, rw As Long 

    Set inputData = Range("B1:E2") //Update to reflect your data 
    temp = inputData.Value 
    inputData.ClearContents 

    rw = 1 
    For i = 1 To UBound(temp) 
     splitData = Split(temp(i, 2), ",") 

     For j = 0 To UBound(splitData) 
      Cells(rw, 2) = temp(i, 1) 
      Cells(rw, 3) = splitData(j) 
      Cells(rw, 5) = temp(i, 4) 
      rw = rw + 1 
     Next j 
    Next i 
End Sub