столбца транспонирование Excel для строк

Question

У меня есть лист Excel, который выглядит как первая картинка, и я хочу, чтобы преобразовать его на вторую картинку:

Я написал следующий код, но он не работает, как ожидался. Он удаляет больше строк, чем ожидалось. Что не так с кодом?

Sub Trans3() 
Dim rng As Range, rng2 As Range 
Dim I As Long 
Dim J As Integer, Z As Integer, Q As Integer, T As Integer 

Set rng = Range("B1") 
While rng.Value <> "" 

For Each y In Range("A1:A10") 
    I = I + 1 
    J = I 
    Z = 1 
    Do While Cells(J + 1, 1).Value = Cells(J, 1).Value 
     J = J + 1 
    Loop      
    Set rng2 = Range("B" & I & ":B" & J) 

    If I > 1 Then 
     Z = J - I + 1 
    Else 
     Z = J 
    End If 

    rng2.Resize(Z).Copy 
    Range("C" & I).PasteSpecial Transpose:=True 
    T = I 

    Do While J > 1 
     Q = T + 1 
     Rows(Q).EntireRow.Delete 
     J = J - 1 
    Loop 

Next y 
Wend 

End Sub 

Answer 1

Так что я сделал небольшой рефакторинг. Я переместил все в массивы, чтобы ускорить его.

См. Примечания в коде для справки.

Sub FOOO() 
Dim inArr() As Variant 
Dim outArr() As Variant 
Dim ws As Worksheet 
Dim cntrw As Long 
Dim cntclm As Long 
Dim i As Long 
Dim j As Long 
Dim k As Long 
Dim rng As Range 

Set ws = ActiveSheet 

With ws 
    Set rng = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)) 
    'find the max number column that will be needed in the output 
    cntclm = ws.Evaluate("MAX(COUNTIF(" & rng.Address & "," & rng.Address & "))") + 1 
    'find the number of rows that will be needed in the output. 
    cntrw = ws.Evaluate("SUM(1/COUNTIF(" & rng.Address & "," & rng.Address & "))") 
    'put the existing data into an an array 
    inArr = rng.Resize(, 2).Value 
    'resize output array to the extents needed 
    ReDim outArr(1 To cntrw, 1 To cntclm) 
    'put the first value in the first spot in the output 
    outArr(1, 1) = inArr(1, 1) 
    outArr(1, 2) = inArr(1, 2) 
    'these are counters to keep track of which slot the data should go. 
    j = 3 
    k = 1 
    'loop through the existing data rows 
    For i = 2 To UBound(inArr, 1) 
     'test whether the data in A has changed or not. 
     If inArr(i, 1) = inArr(i - 1, 1) Then 
      'if not put the value in B in the next slot and iterate to the next column 
      outArr(k, j) = inArr(i, 2) 
      j = j + 1 
     Else 
      'if change start a new line in the outarr and fill the first two slots 
      k = k + 1 
      j = 3 
      outArr(k, 1) = inArr(i, 1) 
      outArr(k, 2) = inArr(i, 2) 
     End If 
    Next i 
    'remove old data 
    .Range("A:B").Clear 
    'place new data in its place. 
    .Range("A1").Resize(UBound(outArr, 1), UBound(outArr, 2)).Value = outArr 
End With 
End Sub 

Это требует, чтобы данные были отсортированы по колонке А.

Answer 2

Shank, используя свой код, я сделал незначительные модификации, и теперь он удаляет правильное число строк, и это работает, попробуйте вне.

Sub Transpose() 

Dim sht As Worksheet 
Dim LastRow As Long 

Set sht = ThisWorkbook.Worksheets("Sheet_Name") ' modify here to your Worksheet name 
LastRow = sht.Cells(sht.Rows.count, "A").End(xlUp).row 

    For row = 1 To LastRow 
     If sht.Cells(row, 1) <> "" Then 
      i = i + 1 
      j = i 
      Z = 1 
      Do While Cells(j + 1, 1).Value = Cells(j, 1).Value 
       j = j + 1 
      Loop 

      Set rng2 = Range("B" & i & ":B" & j) 

      If i > 1 Then 
       Z = j - i + 1 
      Else 
       Z = j 
      End If 

      rng2.Resize(Z).Copy 
      Range("C" & i).PasteSpecial Transpose:=True 
      T = i 

      Do While j - row > 0 
       Q = T + 1 
       Rows(Q).EntireRow.Delete 
       j = j - 1 
      Loop 
     End If 
    Next 

End Sub 

Answer 3

Я принимаю эту проблему.

Sub test() 

    Dim lCtrRow_Raw  As Long 
    Dim lCtrRow_New  As Long 
    Dim lInst   As Long 

    Dim dctUniq   As New Dictionary 
    Dim sKey 
    Dim arrRaw 
    Dim arrNew() 

    '/ Specify your range here. Only two columns of data should be used. 
    arrRaw = Selection() ' ****Avoid using Selection in actual code****. 

    '/ Filter Duplicates. 
    For lCtrRow_Raw = LBound(arrRaw) To UBound(arrRaw) 
     If Not dctUniq.Exists(arrRaw(lCtrRow_Raw, 1)) Then 
      dctUniq.Add arrRaw(lCtrRow_Raw, 1), arrRaw(lCtrRow_Raw, 1) 
     End If 
    Next 

    '/ Start New Array 
    ReDim arrNew(1 To dctUniq.Count, 1 To 1) 

    '/ Seed IDs 
    For Each sKey In dctUniq.Keys 
     lCtrRow_New = lCtrRow_New + 1 
     arrNew(lCtrRow_New, 1) = dctUniq(sKey) 
    Next 

    '/ Loop and assign unique values 
    For lCtrRow_New = LBound(arrNew) To UBound(arrNew) 
     lInst = 1 
    For lCtrRow_Raw = LBound(arrRaw) To UBound(arrRaw) 
      If arrRaw(lCtrRow_Raw, 1) = arrNew(lCtrRow_New, 1) Then 
       lInst = lInst + 1 
       If lInst > UBound(arrNew, 2) Then 
        ReDim Preserve arrNew(1 To dctUniq.Count, 1 To lInst) 
       End If 

       arrNew(lCtrRow_New, lInst) = arrRaw(lCtrRow_Raw, 2) 
      End If 
     Next 
    Next 

    '/ Dump array in the data sheet. 
    'Sheet1.Range("A20").Resize(UBound(arrNew, 1), UBound(arrNew, 2)).Value = arrNew 
End Sub