动态范围数据垂直转水平：VBA代码数据乱序问题求助

Let's break down why your current code is causing out-of-order, incomplete data, then fix it step by step.

The Core Issue in Your Original Code #

Your code only copied the Export items value (column 4) for extra rows, but didn’t carry over the matching fixed attributes (columns 1-3) and insurance value (last row of the column) for each entry. This left most fields blank or incorrectly repeated, leading to messy, unstructured output.

Corrected VBA Code #

Sub test2()
    Dim Ws As Worksheet
    Dim toWs As Worksheet
    Dim vDB, vR()
    Dim rngDB As Range
    Dim i As Long, j As Long, n As Long
    Dim r As Long, c As Long
    
    Set Ws = Sheets(1)
    Set toWs = Sheets(2)
    Set rngDB = Ws.Range("a1").CurrentRegion
    vDB = rngDB
    r = UBound(vDB, 1)
    c = UBound(vDB, 2)
    
    ' Initialize row counter for output array
    n = 0
    
    For j = 2 To c ' Loop through each data column (B, C, etc.)
        ' Store fixed, consistent attributes for this column
        Dim fixedAttr1 As Variant, fixedAttr2 As Variant, fixedAttr3 As Variant
        Dim insuranceVal As Variant
        fixedAttr1 = vDB(1, j)
        fixedAttr2 = vDB(2, j)
        fixedAttr3 = vDB(3, j)
        insuranceVal = vDB(r, j)
        
        ' Add the initial row (using the 4th row's Export item)
        n = n + 1
        ReDim Preserve vR(1 To 5, 1 To n)
        vR(1, n) = fixedAttr1
        vR(2, n) = fixedAttr2
        vR(3, n) = fixedAttr3
        vR(4, n) = vDB(4, j)
        vR(5, n) = insuranceVal
        
        ' Add all non-empty extra Export items from rows 5 to r-1
        For i = 5 To r - 1
            If Trim(vDB(i, j)) <> "" Then ' Ignore cells with only whitespace
                n = n + 1
                ReDim Preserve vR(1 To 5, 1 To n)
                ' Carry over all fixed attributes + current Export item + insurance
                vR(1, n) = fixedAttr1
                vR(2, n) = fixedAttr2
                vR(3, n) = fixedAttr3
                vR(4, n) = vDB(i, j)
                vR(5, n) = insuranceVal
            End If
        Next i
    Next j
    
    ' Paste the transposed output to the target sheet
    With toWs
        Dim targetStartRow As Long
        targetStartRow = .UsedRange.Rows.Count + 1
        .Range("a" & targetStartRow).Resize(n, 5) = WorksheetFunction.Transpose(vR)
    End With
End Sub

Key Improvements #

• Preserve All Attributes: For each column, we store the consistent values (rows 1-3 and insurance) so every generated row includes these details, matching your manual transposition result.
• Full Row Generation: Every non-empty Export item (including the 4th row and rows 5 to r-1) gets its own complete row with no missing data.
• Robust Empty Check: Added Trim() to skip cells that only contain whitespace, preventing false positives.
• Cleaner Readability: Separated fixed values into distinct variables to make the code easier to follow and modify later.

This code will now correctly convert your vertical dynamic range to horizontal format while keeping all associated data intact and in order.

内容的提问来源于stack exchange，提问作者Amit Shah