Este fórum está sendo desativado

[babdallas]

Veja se ajuda.

Código: Selecionar todos

Public Sub Transpor2()
    Dim lngUltLin       As Long
    Dim lngCont         As Long
    Dim datData         As Date
    Dim lngLin          As Long
    Dim lngLins         As Long
    Dim lngLinColar     As Long
    Dim strTipo         As String
    
    Application.ScreenUpdating = False
    
    With wshTeste
        .Range("F2:L" & .Rows.Count).ClearContents
        .Range("F2:L" & .Rows.Count).Interior.Color = vbWhite
    
        lngUltLin = .Cells(.Rows.Count, 1).End(xlUp).Row
        datData = .Range("A2").Value
        lngLin = 2
        lngLinColar = 2
        For lngCont = 2 To lngUltLin
            If .Cells(lngCont, 3).Value <> vbNullString Then strTipo = .Cells(lngCont, 3).Value
        
            If datData <> .Cells(lngCont + 1, 1).Value Then
                .Cells(lngLinColar, 6).Value = datData
                .Cells(lngLinColar, 13).Value = strTipo
                lngLins = lngCont + 1 - lngLin
                
                .Cells(lngLin, 2).Resize(lngLins).Copy
                .Cells(lngLinColar, 7).Resize(, lngLins).PasteSpecial Paste:=xlPasteAll, _
                                                                    Operation:=xlNone, SkipBlanks:=False, _
                                                                    Transpose:=True
                
                datData = .Cells(lngCont + 1, 1).Value
                strTipo = vbNullString
                lngLin = lngCont + 1
                lngLinColar = lngLinColar + 1
            End If
        Next lngCont
    End With

    Application.ScreenUpdating = True
End Sub

[osvaldomp]

Experimente:

Código: Selecionar todos

Sub ReplicaDados()
 Dim c As Long, k As Long
  Application.ScreenUpdating = False
  If [F2] <> "" Then
   Range("F2:M" & Cells(Rows.Count, 6).End(3).Row).Interior.Color = xlNone
   Range("F2:M" & Cells(Rows.Count, 6).End(3).Row) = ""
  End If
  For c = 2 To Cells(Rows.Count, 1).End(3).Row
   k = Application.CountIf([A:A], Cells(c, 1))
   Cells(c, 1).Copy Cells(Rows.Count, 6).End(3)(2)
   Cells(c, 2).Resize(k).Copy
   Cells(Rows.Count, 7).End(3)(2).PasteSpecial xlAll, Transpose:=True
   If Application.CountA(Cells(c, 3).Resize(k)) > 0 Then
   Cells(Rows.Count, 6).End(3)(1, 8) = Evaluate("INDEX(" & Cells(c, 3).Resize(k).Address & ",MATCH(TRUE," & Cells(c, 3).Resize(k).Address & "<>"""",0))")
   End If
   c = c + k - 1
  Next c
  Application.ScreenUpdating = True
End Sub