Сложная перенос с использованием Excel VBA

Question

Я надеюсь, кто-то может помочь мне очистить некоторые данные с листа, а затем транспонировать намного больше.

У меня есть исключительно медленный способ сделать это в настоящий момент, когда миллионы строк очень плохого кода просто записывают различные шаги, но каждый раз он разбивает мой компьютер, поэтому я надеюсь, что есть более быстрый способ.

Я приложил образец документа, для которого теперь выглядит информация, и как мне хотелось бы выглядеть потом.

Я использовал два листа для ясности, но в идеале хотел бы, чтобы действие произошло поверх всего листа на одном листе. Это не важно.

В выборке есть три члена, но на самом деле их может быть 100 секунд.

Я надеюсь, что информация в A18: B20 удалена, чтобы следовать таким образом для каждого члена, поэтому удаляем строки, относящиеся к приведенному ниже, а затем переносим оставшуюся информацию.

• Тип
• Последний Рассматриваемый
• Последнее уведомление

Я не могу прикрепить или размещать фото так вот ссылка - http://www.filedropper.com/sample_5

Заранее спасибо за вашу помощь ,

Answer 1

Вопросы, касающиеся кода запроса, указывают на то, что пользователь имеет базовые знания в области кодирования VBA, поэтому я предоставлю вам частичное решение, которое вы сможете адаптировать к вашим конкретным потребностям. Вы предоставили хорошие примеры своих требований до и после - что-то, что критично и часто не хватает. Они были бы лучше, если бы они были уникальными, а не идентичными.

Макрос должен воспроизводить то, что у вас есть на ваших листах. В частности, предполагается, что данные находятся в столбцах A и B на листе «Сейчас» и будут записывать результаты на лист «После». Но вы должны быть в состоянии выяснить, возможно, с некоторыми исследованиями, как это изменить. Поместите этот код в обычный модуль.

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