Question

我希望有人可以帮我清除工作表中的一些数据，然后转置更多。

我现在有一种非常缓慢的方式，只需记录各种步骤就会有数百万行非常糟糕的代码，但每次都会崩溃我的计算机，所以我希望有更快的方法。

我附上了一份示例文档，其中包含了现在的信息以及之后我希望看到的信息。

为了清晰起见，我使用了两张纸，但理想情况下，想要在一张纸的顶部进行操作。但这并不重要。

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

我希望删除A18：B20中的信息，以这种方式对每个成员进行操作，因此删除与下面相关的行，然后转置剩余的信息。

类型
上次查看
上次通知

我似乎无法附加或发布图片，所以这里有一个链接 - http://www.filedropper.com/sample_5

提前感谢您的帮助。

Answer 1

此处请求代码的问题表明用户具有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

使用Excel VBA进行复杂的转置

1 个答案: