使用Excel VBA進行復雜的轉置

Question

我希望有人可以幫助我清除工作表中的一些數據，然後轉置更多。

我有一個非常緩慢的方式做這件事的時候，只是記錄各種步驟的數百萬行非常糟糕的代碼，但它每次都會崩潰我的電腦，所以我希望有一個更快的方法。

我附上了一個示例文檔，說明現在的信息是什麼樣的，以及我希望事後看起來如何。

爲了清晰起見，我使用了兩張紙，但理想情況下希望在一張紙上的頂部發生動作。但這不是必需的。

樣本中有三名成員，但實際上可能有100名成員。

我希望將A18：B20中的信息刪除，按照這種方式對每個成員進行跟蹤，因此刪除與下面相關的行，然後轉換其餘信息。

• 類型
• 上次查看
• 最後通知

我似乎無法使這裏附或交的圖片是一個鏈接 - http://www.filedropper.com/sample_5

預先感謝您的幫助。

Answer 1

此處請求代碼的問題表明用戶具有VBA編碼的基本知識，因此我將爲您提供一個部分解決方案，您應該可以根據您的特定需求量身定製。你確實提供了你的前後要求的很好的例子 - 這是非常重要的，經常缺乏的。不過，如果他們是獨一無二的，而不是相同的話，他們會更好。

宏應該重現您在工作表上的內容。特別是它假設數據在工作表「現在」的列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