VBA Return 运输和填充代码

Question

我是 vba 的新手，非常感谢对我遇到的以下问题的任何帮助。

问题描述（与下图相关）： 1*) 在 c 中，我设法将 return 车厢分开，这导致 2*) 现在每个 return 车厢都有它自己的行，我需要两边的 b 列和 c 列如结果 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

结束子

谢谢，

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

VBA Return 运输和填充代码

VBA Return Carriage and Fill Code

vba

excel

return

carriage-return