用excelvba实现复杂转置

我希望有人能帮我清除工作表中的一些数据，然后转换更多数据

我有一个非常缓慢的方式来做这件事，目前有数百万行非常糟糕的代码，只是记录不同的步骤，但每次它崩溃我的电脑，所以我希望有一个更快的方式

我附上了一个示例文档，说明了信息现在的样子以及以后的样子

为了清晰起见，我用了两张纸，但理想情况下，我希望动作发生在一张纸的顶部。但这并不是必要的

样本中有三名成员，但实际上可能有100名

我希望删除A18:B20中的信息，以这种方式为每个成员跟踪，因此删除与下面相关的行，然后转置剩余的信息

• 类型
• 上次查看
• 最后通知

我似乎无法附加或张贴图片，因此这里有一个链接-

---

提前感谢您的帮助。

此处请求代码的问题表明用户具有VBA编码的基本知识，因此我将为您提供一个部分解决方案，您应该能够根据自己的具体需求进行定制。您确实为您的前后需求提供了很好的示例——这是非常关键的，而且常常是缺少的。不过，如果它们是独一无二的，而不是一模一样的，它们会更好

宏应该复制工作表上的内容。特别是，它假设数据位于工作表“Now”的A列和B列中，并将结果写入工作表“After”。但是你应该能够弄清楚，也许通过一些研究，如何改变这种状况。将此代码放入常规模块中

Option Explicit
Sub TransposeMemberList()
    Dim sColHdrs() As String
    Dim vSrc As Variant
    Dim vRes() As Variant
    Dim I As Long, J As Long, K As Long
    Dim lCols As Long
    Dim lMembers As Long
    Dim wsSrc As Worksheet, wsRes As Worksheet
    Dim rDest As Range

'Set results Range First Cell
Set wsRes = Worksheets("After")
Set rDest = wsRes.Range("A1")

'get Source Data
Set wsSrc = Worksheets("Now")
With wsSrc
    vSrc = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Resize(columnsize:=2)
End With

'Assume colheaders all exist in first record
'Col Hdr 1 = Name
'How many columns?  Count to first blank in col A
With wsSrc.Cells.Columns(1)
    lCols = .Find(what:="", after:=[A1], LookIn:=xlValues, _
                        lookat:=xlWhole, searchorder:=xlByRows, _
                        searchdirection:=xlNext).Row - 1
End With

'How many Members?
'Count number of instances of first named column
lMembers = WorksheetFunction.CountIf(wsSrc.Cells.Columns(1), vSrc(2, 1))

'Populate Results Array
'First do column headers
ReDim vRes(1 To lMembers + 1, 1 To lCols)
vRes(1, 1) = "Name"
For I = 2 To lCols
    vRes(1, I) = vSrc(I, 1)
Next I

'Now do the columns for each memeber
'I = Member Rows in "Now"
'J = Member Row in "After"
'K = Member Column
I = 1
For J = 1 To lMembers
    vRes(J + 1, 1) = vSrc(I, 1)
    For K = 2 To lCols
        I = I + 1
        vRes(J + 1, K) = vSrc(I, 2)
    Next K

    'set I to next member by checking for first column header
    Do Until vSrc(I, 1) = vSrc(2, 1)
        I = I + 1
        If I > UBound(vSrc) Then Exit Do
    Loop
    I = I - 1
Next J


Set rDest = rDest.Resize(rowsize:=UBound(vRes, 1), columnsize:=UBound(vRes, 2))
rDest.EntireColumn.Clear
rDest = vRes
rDest.EntireColumn.AutoFit


End Sub

---

您的数据是否如示例所示格式良好？所有“待列标题”都相同；而且总是按同样的顺序？所有所需的标题是否都是连续的（数据中没有空行），要删除的三行是否由空行抵消？Hi Ron。谢谢你回来。数据格式良好，B列中可能有一些空白字段，但A列将始终遵循该模式。完美！谢谢，罗恩，非常感谢。也谢谢你的建议，我下次一定会遵守的。