Excel 特殊格式的转置

今天，我完成了by VBA课程的循环部分，并进行了一些实践，但我遇到了一个似乎无法解决的问题

我想将数据从表1转换到表2

表1

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

我试图编写一个宏，将数据转换为表2，如下所示：

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

我试图写一些VBA代码，但我不知道如何解决这个特殊的问题。我尝试使用Do-Until循环，但遇到的问题是如何将第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

---

这将为您解决问题

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

Public Sub-TransformData（）
Dim lngRow为长，lngEndRow为长，objSrcSheet为工作表，OBJDESTSEET为工作表
Dim strLetter为字符串，strNumber为字符串，lngCol为长，lngWriteRow为长
设置objSrcSheet=Sheet1
设置objDestSheet=Sheet2
lngEndRow=objSrcSheet.Range（“A”&objSrcSheet.Rows.Count）.End（xlUp）.Row
带objSrcSheet
对于lngRow=1到lngEndRow
strLetter=.Cells（lngRow，1）
如果strLetter“”那么
对于lngCol=2到.Columns.Count
strNumber=.Cells（lngRow，lngCol）
如果strNumber=“”，则退出
lngWriteRow=lngWriteRow+1
objDestSheet.Cells（lngWriteRow，1）=strLetter
objDestSheet.Cells（lngWriteRow，2）=strNumber
下一个
如果结束
下一个
以
端接头

。。。我决定给你一个完整的解决方案。无论是对是错，最好的还是最坏的，我都会这样做，鉴于你们的学习，我希望这对你们有所帮助。它还采用了一种不使用SELECT的方法，这种方法只会减慢您的速度，被认为是非常糟糕的做法

它假设我的源工作表如下图所示。我希望这有帮助

---

一个简单的Excel相关方法是使用

powerquery

aka

Get&Transform

。选择第一列，然后选择

unpivot

其他列。所有这些都可以通过用户界面完成

如果您希望有一个使用循环来实现相同最终结果的宏，我将执行以下操作。请注意，我在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

选项显式
次到期日（）
'声明变量
将WS1标注为工作表，将WS2标注为工作表
变暗rSrc作为范围，rRes作为范围
尺寸vSrc作为变型，vRes作为变型
Dim lRC（）的长度相同
我长，J长，K长
'设置工作表和范围变量
'确定范围的最后一行和最后一列，假设从A1开始
设置WS1=Sheet1
设置WS2=Sheet2
设置rRes=WS2。单元格（1，1）
lRC=LastRowCol（WS1.Name）
'将源数据读入VBA数组
“比在工作表上操作快得多
使用WS1
设置rSrc=.Range（.Cells（1，1），.Cells（lRC（0），lRC（1）））
vSrc=rSrc
以
'调整结果数组的大小
'注意，'Count'将只计算数值项，这是我们想要的
'如果没有好的文本/数字，可能必须使用不同的计算
'第1列和其余数据之间的差异
重拨VRE（1到工作表函数计数（rSrc），1到2）
“这是回路
'我们一次浏览一行源数据
'如您所见，正在写入结果数组
'需要检查空白条目，因为并非所有行都是相同的
“一样长。
K=0
对于I=1到UBound（vSrc，1）
对于J=2至UBound（vSrc，2）
如果vSrc（I，J）“，则
K=K+1
vRes（K，1）=vSrc（I，1）
vRes（K，2）=vSrc（I，J）
如果结束
下一个J
接下来我
'将结果写入目标工作表
设置rRes=rRes。调整大小（UBound（vRes，1），UBound（vRes，2））
与rRes
.全部清除
.Value=vRes
以
端接头
函数LastRowCol（Worksht作为字符串）作为Long（）
应用程序。挥发性
将WS设置为工作表，R设置为范围
调暗LastRow和LastCol一样长
尺寸L（1）与长度相同
设置WS=工作表（Worksht）
与WS
设置R=.Cells.Find（what:=“*”，after:=.Cells（1,1）_
LookIn:=xlFormulas，lookat:=xlPart，searchorder:=xlByRows_
searchdirection:=xlPrevious）
如果不是的话，R什么都不是
LastRow=R.行
LastCol=.Cells.Find（what:=“*”，after:=.Cells（1,1）_
LookIn:=xlFormulas，lookat:=xlPart，searchorder:=xlByColumns_
searchdirection:=xlPrevious）.列
其他的
LastRow=1
LastCol=1
如果结束
以
L（0）=最后一行
L（1）=LastCol
LastRowCol=L
端函数

源数据

结果

---

在阵列中工作可能更容易导航（当然也更快）

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

选项显式
子堆栈转置（）
尺寸i为长，j为长，k为长，VAL为变型，arr为变型
'将原始值收集到源数组中
附工作表（1）
VAL=.Cells（1，“A”）.CurrentRegion.Value2
以
'重新确定目标阵列的尺寸并为第一行设置k'
ReDim arr（1到应用程序计数（VAL），1到2）
k=1
'通过源循环并传输转置的值
对于i=LBound（VAL，1）到UBound（VAL，1）
对于j=LBound（VAL，2）+1至UBound（VAL，2）
'是否有要转移的值？
如果VAL（i，j）为空字符串，则
arr（k，1）=vals（i，LBound（vals，2））
arr（k，2）=vals（i，j）
'增量目标'行'
k=k+1
其他的
'空白值；移动到下一个源“行”
退出
如果结束
N
{=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)))}

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