excel vba我需要将数据从列转置为行 [英] excel vba I need to transpose data from columns to rows

问题描述

我正在寻找一种VBA解决方案，用于从类似于以下插图的场景转换数据.仅当Sheet2中前三个单元格值(A2)的左侧(D3，E3，...)左侧的任何单元格中都有值时，才从Sheet1复制前三个单元格值(A3，B3，C3) ，B2，C2)，然后是第一个具有值(D3)的单元格，还将标头值复制到相邻的单元格中.左侧的所有其他值将得到相同的处理，并成为下一行，再次复制(A3，B3，C3).然后将下一个相邻单元格值(E3)连同标头值一起放入相邻单元格中.然后向下移动到Sheet1中的下一行，其中前三个单元格之后都有值，直到它一直循环通过sheet1以产生Sheet2中的示例.

I am looking for a VBA solution to transform data from a scenario similar to the illustration below. From Sheet1 copy first three cell values (A3,B3,C3) only if there is a value in any cell to the left of them (D3,E3,...) in Sheet2 past first 3 cell values (A2,B2,C2), and the first cell after that with a value (D3) and also copy the header value into the adjacent cell. Any additional values to the left get the same treatment and become the next row, again copying (A3,B3,C3). Then the next adjacent cell value (E3) along with the header value into the adjacent cell. Then move down to the next row in Sheet1 where there are values after the first 3 cells until it has looped all the way through sheet1 to produce the example in Sheet2.

我已经搜索了其他类似的解决方案，但是找不到任何可行的解决方案.这是我找到的最接近的内容，但进行了少量修改，但是它不起作用，非常感谢您的帮助.

I have searched for other similar solutions but cannot find anything that works. This is the closest I've found with minor edits on my part but doesn’t work, any help is greatly appreciated.

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

推荐答案

使用变量数组(动态数组)既简单又快速.

Using a variant array(dynamic array) is simple and fast.

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

这篇关于excel vba我需要将数据从列转置为行的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！