Guru do Excel e Power BI

Sub OrganizaDados()
 Dim c As Range, rng As Range, fAdd As String, x As Long, y As Long, LR As Long
  Application.ScreenUpdating = False
  Sheets("RelatDesp").[A:E] = ""
  Set rng = Range("A1:A" & Cells(Rows.Count, 1).End(3).Row)
   Set c = rng.Find("1.*", Lookat:=xlWhole)
   If Not c Is Nothing Then
    fAdd = c.Address
    Do
     x = c.Row
     Set c = rng.FindNext(c)
     y = IIf(c.Address <> fAdd, c.Row, Cells(Rows.Count, 1).End(3).Row)
     With Sheets("RelatDesp")
      LR = .Cells(Rows.Count, 1).End(3).Row
      .Cells(LR + 1, 1).Resize(y - x - 1).Value = Cells(x, 1)
      .Cells(LR + 1, 2).Resize(y - x - 1).Value = Cells(x, 2)
      .Cells(LR + 1, 3).Resize(y - x - 1).Value = Cells(x + 1, 1).Resize(y - x - 1).Value
      .Cells(LR + 1, 4).Resize(y - x - 1).Value = Cells(x + 1, 2).Resize(y - x - 1).Value
      .Cells(LR + 1, 5).Resize(y - x - 1).Value = Cells(x + 1, 3).Resize(y - x - 1).Value
     End With
    Loop While Not c Is Nothing And c.Address <> fAdd
   End If
  On Error Resume Next
  Set c = rng.Find("1.*", Lookat:=xlPart)
  Application.ScreenUpdating = True
End Sub