Question

我对vba真的很新，并希望能解决我遇到的以下问题。

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

End 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

VBA返回运输和填充代码

2 个答案: