Question

今天，我完成了VBA课程的循环部分，并做了一些练习，但是遇到了一个我似乎无法解决的问题。

我想将数据从工作表1转换到工作表至工作表2。

第1张纸

a   1   2   3
b   1   2   3   4   5   6
c   1   2   3   4

我正在尝试编写一个宏，它将像这样将数据转置到Sheet 2中：

我试图编写一些VBA代码，但是我不知道如何解决这个特殊问题。我尝试使用“直到循环”，但是遇到的问题是如何获取工作表1，第1列中的字母，并将其对应的数字粘贴到工作表2中。

一个朋友为我分析了一些代码，但这使我更加困惑。它适用于此数据集，但无法使用较大的数据集（字母升至“ z”的数据集）执行此操作。

这是他的代码：

Sub transpose()
    Sheets(1).Select

    lrow1 = Cells(Rows.Count, 1).End(xlUp).Row

    For i = 1 To lrow1
        nums = 2

        Cells(i, nums).Select

        Do Until IsEmpty(ActiveCell)
            nums = nums + 1
            Cells(i, nums).Select
        Loop

        Range(Cells(i, 2), Cells(i, nums)).Copy
        Sheets(2).Select

        lrow2 = Cells(Rows.Count, 2).End(xlUp).Row

        Cells(lrow2 + 1, 2).Select

        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, transpose:=True

        Sheets(1).Select

        Cells(i, 1).Copy

        Sheets(2).Select

        Cells(lrow2 + 1, 1).Select

        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, transpose:=False

        lrow3 = Cells(Rows.Count, 2).End(xlUp).Row

        Cells(lrow2 + 1, 1).Select

        Selection.AutoFill Destination:=Range(Cells(lrow2 + 1, 1), Cells(lrow3, 1)), Type:=xlFillDefault

        Sheets(1).Select
    Next i

    Sheets(2).Select

    Rows("1:1").Select

    Selection.Delete Shift:=xlUp
End Sub

https://pastebin.com/J45fmYKj

Answer 1

这将为您做...

Public Sub TransformData()
    Dim lngRow As Long, lngEndRow As Long, objSrcSheet As Worksheet, objDestSheet As Worksheet
    Dim strLetter As String, strNumber As String, lngCol As Long, lngWriteRow As Long

    Set objSrcSheet = Sheet1
    Set objDestSheet = Sheet2

    lngEndRow = objSrcSheet.Range("A" & objSrcSheet.Rows.Count).End(xlUp).Row

    With objSrcSheet
        For lngRow = 1 To lngEndRow
            strLetter = .Cells(lngRow, 1)

            If strLetter <> "" Then
                For lngCol = 2 To .Columns.Count
                    strNumber = .Cells(lngRow, lngCol)

                    If strNumber = "" Then Exit For

                    lngWriteRow = lngWriteRow + 1

                    objDestSheet.Cells(lngWriteRow, 1) = strLetter
                    objDestSheet.Cells(lngWriteRow, 2) = strNumber
                Next
            End If
        Next
    End With
End Sub

...我决定为您提供完整的解决方案。对或错，最好或最坏，这就是我要这样做的方法，并且鉴于您正在学习，希望它能对您有所帮助。它还采用了一种不使用SELECT的方法，它只会降低速度，并且被认为是非常糟糕的做法。

它假定我的源工作表如下图所示。希望对您有所帮助。

Answer 2

一种简单的与Excel相关的方法是使用Power Query或Get&Transform。选择第一列，然后选择unpivot Other列。所有这些操作都可以通过用户界面完成。

如果您想要一个使用循环完成相同最终结果的宏，我将执行以下操作。请注意，我在VBA数组中执行循环，而不是使用对工作表的反复调用。这是一种更快的方法。

Option Explicit
Sub due()
    'Declare the variables
    Dim WS1 As Worksheet, WS2 As Worksheet
    Dim rSrc As Range, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim lRC() As Long
    Dim I As Long, J As Long, K As Long

'Set Worksheet and Range variables
'Determine Last Row and Column of the range, assuming starts in A1
Set WS1 = Sheet1
Set WS2 = Sheet2
    Set rRes = WS2.Cells(1, 1)
lRC = LastRowCol(WS1.Name)

'Read the source data into a VBA array
'much faster than operating on the worksheet
With WS1
    Set rSrc = .Range(.Cells(1, 1), .Cells(lRC(0), lRC(1)))
    vSrc = rSrc
End With

'size the results array
'note that `Count` will only count the numeric entries, which is what we want
'might have to use a different computation if there is not a nice text/number
'differentiation between column 1 and the rest of the data
ReDim vRes(1 To WorksheetFunction.Count(rSrc), 1 To 2)

'Here is the loop
'we go through the source data one row at a time
'writing to the results array as you can see
'Need to check for blank entries since not all rows are the
' same length.
K = 0
For I = 1 To UBound(vSrc, 1)
    For J = 2 To UBound(vSrc, 2)
        If vSrc(I, J) <> "" Then
            K = K + 1
            vRes(K, 1) = vSrc(I, 1)
            vRes(K, 2) = vSrc(I, J)
        End If
    Next J
Next I

'write the results to the destination worksheet
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
End With

End Sub

Function LastRowCol(Worksht As String) As Long()
Application.Volatile
    Dim WS As Worksheet, R As Range
    Dim LastRow As Long, LastCol As Long
    Dim L(1) As Long
Set WS = Worksheets(Worksht)
With WS
    Set R = .Cells.Find(what:="*", after:=.Cells(1, 1), _
                    LookIn:=xlFormulas, lookat:=xlPart, searchorder:=xlByRows, _
                    searchdirection:=xlPrevious)

    If Not R Is Nothing Then
        LastRow = R.Row
        LastCol = .Cells.Find(what:="*", after:=.Cells(1, 1), _
                    LookIn:=xlFormulas, lookat:=xlPart, searchorder:=xlByColumns, _
                    searchdirection:=xlPrevious).Column
    Else
        LastRow = 1
        LastCol = 1
    End If
End With

L(0) = LastRow
L(1) = LastCol
LastRowCol = L
End Function

源数据

结果

Answer 3

导航（当然更快）以在数组中工作可能更容易。

Option Explicit

Sub stackTranspose()

    Dim i As Long, j As Long, k As Long, vals As Variant, arr As Variant

    'collect original values into source array
    With Worksheets(1)
        vals = .Cells(1, "A").CurrentRegion.Value2
    End With

    'redimension target array and set k for first 'row'
    ReDim arr(1 To Application.Count(vals), 1 To 2)
    k = 1

    'loop through source and transfer transposed values
    For i = LBound(vals, 1) To UBound(vals, 1)
        For j = LBound(vals, 2) + 1 To UBound(vals, 2)
            'is there a value to transfer?
            If vals(i, j) <> vbNullString Then
                arr(k, 1) = vals(i, LBound(vals, 2))
                arr(k, 2) = vals(i, j)
                'increment target 'row'
                k = k + 1
            Else
                'blank value; move to next source 'row'
                Exit For
            End If
        Next j
    Next i

    'put target values into Sheeet2
    With Worksheets(2)
        .Cells(1, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    End With

End Sub

Answer 4

我知道您要一个宏，但只想通过公式为您提供替代方法：

Sheet1：

Sheet2：

A1中的公式：

{=INDEX(Sheet1!$A$1:$A$3,SMALL((Sheet1!$B$1:$G$3>0)*ROW(Sheet1!$B$1:$G$3),ROW()+COUNTBLANK(Sheet1!$B$1:$G$3)))}

B1中的公式：

=INDEX(Sheet1!$A$1:$G$3,MATCH(A1,Blad1!$A$1:$A$3,0),COUNTIF($A$1:A1,A1)+1)

请注意，第一个公式需要通过 Ctrl Shift Enter

输入

向下拖动公式。...

祝你好运，ps。可能还有其他公式。

特殊格式转置

4 个答案: