Question

我需要帮助调整下面的代码。屏幕截图列在标有＆＃39;屏幕截图＆＃39;的代码下方。它是我试图分离的类似数据的示例格式。我有这种格式的3000多行数据。下面的代码能够拆分一列并复制数据，但现在我必须与位置和日期进行一对一的映射，并复制所有相应的数据。任何意见都会非常感激。

我希望数据不仅可以在半冒号中分割成单独的行，还可以将日期与每个相应的位置对应，并复制它们旁边的数据。

这是我在一个特定列上使用的代码。提前致谢！代码的来源是关于堆栈溢出的帖子：一个非常有用的代码。 Scripting in Excel - Insert new row based on comma-separated list

Sub SplitPartsRows()
Dim rng As Range
Dim r As Long
Dim arrParts() As String
Dim partNum As Long
Dim Trail As String
'## In my example i use columns A:E, and column D contains the Corresponding Parts ##

Set rng = Range("A1:BI13876") '## Modify as needed ##'

r = 2

Do While r <= rng.Rows.Count
    '## Split the value in column BB (54) by commas, store in array ##
    arrParts = Split(rng(r, 17).Value, ";")
    '## If there's more than one item in the array, add new lines ##
    If UBound(arrParts) >= 1 Then '## corrected this logic for base 0 array
        rng(r, 17).Value = arrParts(0)

        '## Iterate over the items in the array ##
        For partNum = 1 To UBound(arrParts)
            '## Insert a new row ##'
            '## increment the row counter variable ##
            r = r + 1
            rng.Rows(r).Insert Shift:=xlDown

            '## Copy the row above ##'
            rng.Rows(r).Value = rng.Rows(r - 1).Value

            '## update the part number in the new row ##'
            rng(r, 17).Value = Trim(arrParts(partNum))

            '## resize our range variable as needed ##
            Set rng = rng.Resize(rng.Rows.Count + 1, rng.Columns.Count)

        Next

    End If
'## increment the row counter variable ##
r = r + 1
Loop

End Sub

Screenshot

Answer 1

试试这个：

Sub Reformat()
    Dim rwIn As Range, rwOut As Range
    Dim arrLoc, arrDt, locs, dts, i

    Set rwIn = ActiveSheet.Range("A2:E2")
    Set rwOut = ActiveSheet.Range("G2:K2")

    Do While Application.CountA(rwIn) > 0
        locs = rwIn.Cells(2).Value
        dts = rwIn.Cells(4).Value

        If Len(locs) > 0 And Len(dts) > 0 Then
            arrLoc = Split(locs, ";")
            arrDt = Split(dts, ";")
            For i = LBound(arrLoc) To UBound(arrLoc)
                With rwOut
                    .Cells(1) = rwIn.Cells(1)
                    .Cells(2) = arrLoc(i)
                    .Cells(3) = rwIn.Cells(3)
                    If i <= UBound(arrDt) Then
                        .Cells(4) = arrDt(i)
                    End If
                    .Cells(5) = rwIn.Cells(5)
                End With
                Set rwOut = rwOut.Offset(1, 0)
            Next i
        End If
        Set rwIn = rwIn.Offset(1, 0)
    Loop
End Sub

在两列中拆分带有半冒号的文本，并将相应数据的一对一映射重复

1 个答案: