Question

我正在寻找一种VBA解决方案来转换类似于下图的场景中的数据。从Sheet1复制前三个单元格值（A3，B3，C3），只有在Sheet2过去的前一个3中，它们左边的任何单元格（D3，E3，...）中都有值单元格值（A2，B2，C2），以及具有值（D3）的第一个单元格，并且还将标题值复制到相邻单元格中。左边的任何附加值得到相同的处理并成为下一行，再次复制（A3，B3，C3）。然后将下一个相邻的单元格值（E3）连同标题值一起放入相邻的单元格中。然后向下移动到Sheet1中的下一行，其中前三个单元格后面有值，直到它一直循环到sheet1以生成Sheet2中的示例。

我搜索过其他类似的解决方案但找不到有效的方法。这是我发现的最接近我编辑的小编辑，但不起作用，非常感谢任何帮助。

Sub Sample()
Dim wsThis As Worksheet
Dim wsThat As Worksheet
Dim ThisAr As Variant
Dim ThatAr As Variant
Dim Lrow As Long
Dim Col As Long
Dim i As Long
Dim k As Long

Set wsThis = Sheet1: Set wsThat = Sheet2

With wsThis
    '~~> Find Last Row in Col A
    Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
    '~~> Find total value in D,E,F so that we can define output array
    Col = Application.WorksheetFunction.CountA(.Range("C2:G" & Lrow))

    '~~> Store the values from the range in an array
    ThisAr = .Range("A2:G" & Lrow).Value

    '~~> Define your new array
    ReDim ThatAr(1 To Col, 1 To 7)

    '~~> Loop through the array and store values in new array
    For i = LBound(ThisAr) To UBound(ThisAr)
        k = k + 1

        ThatAr(k, 1) = ThisAr(i, 1)
        ThatAr(k, 2) = ThisAr(i, 2)
        ThatAr(k, 3) = ThisAr(i, 3)

        '~~> Check for Color 1
        If ThisAr(i, 5) <> "" Then 'ThatAr(k, 4) = ThisAr(i, 4)
            k = k + 1
            ThatAr(k, 1) = ThisAr(i, 1)
            ThatAr(k, 2) = ThisAr(i, 2)
            ThatAr(k, 3) = ThisAr(i, 3)
            ThatAr(k, 4) = ThisAr(i, 4)
            ThatAr(k, 5) = ThisAr(i, 5)
        End If

        '~~> Check for Color 2
        If ThisAr(i, 7) <> "" Then
            k = k + 1
            ThatAr(k, 1) = ThisAr(i, 1)
            ThatAr(k, 2) = ThisAr(i, 2)
            ThatAr(k, 3) = ThisAr(i, 3)
            ThatAr(k, 6) = ThisAr(i, 6)
            ThatAr(k, 7) = ThisAr(i, 7)
        End If

        '~~> Check for Color 3
        'If ThisAr(i, 6) <> "" Then
            'k = k + 1
            'ThatAr(k, 1) = ThisAr(i, 1)
            'ThatAr(k, 2) = ThisAr(i, 2)
            'ThatAr(k, 3) = ThisAr(i, 3)
            'ThatAr(k, 4) = ThisAr(i, 6)
        'End If
    Next i
End With

'~~> Create headers in Sheet2
Sheet2.Range("A1:D1").Value = Sheet1.Range("A1:D1").Value

'~~> Output the array
wsThat.Range("A2").Resize(Col, 4).Value = ThatAr
End Sub

Answer 1

使用变量数组（动态数组）简单快捷。

Sub test()
    Dim wsThis As Worksheet, wsThat As Worksheet
    Dim vDB As Variant, vR() As Variant
    Dim r As Long, i As Long, n As Long
    Dim c As Integer, j As Integer, k As Integer

    Set wsThis = Sheet1: Set wsThat = Sheet2

    vDB = wsThis.Range("a1").CurrentRegion
    r = UBound(vDB, 1)
    c = UBound(vDB, 2)

    For i = 2 To r
        For j = 4 To c
            If vDB(i, j) <> "" Then
                n = n + 1
                ReDim Preserve vR(1 To 5, 1 To n)
                For k = 1 To 3
                    vR(k, n) = vDB(i, k)
                Next k
                vR(4, n) = vDB(i, j)
                vR(5, n) = vDB(1, j)
            End If
        Next j
    Next i
    With wsThat
        .UsedRange.Clear
        .Range("a1").Resize(1, 3) = wsThis.Range("a1").Resize(1, 3).Value
        .Range("d1").Resize(1, 2) = Array("Value", "ID#")
        .Range("a2").Resize(n, 5) = WorksheetFunction.Transpose(vR)
    End With
End Sub

Answer 2

抱歉，我不确定为什么我无法打开您附加的图片。但您可能想尝试此代码：

Change this line:
wsThat.Range("A2").Resize(Col, 4).Value = ThatAr
To
wsThat.Range("A2").Resize(4, Col).Value = WorksheetFunction.Transpose(ThatAr)

希望这个帮助

excel vba我需要将数据从列转换为行

2 个答案: