Help with macro to transpose data

See attached file where I used this macro to transpose data as you asked.

Sub Macro1()
   Dim sh1 As Worksheet
   Dim sh2 As Worksheet
   Dim r As Long, lastRow As Long
   Dim myRef As Long, myOldRef As Long
   Dim myDate As Date, myCol As Integer
   Dim nrDates As Integer, c As Integer
   Dim elem As Variant, destRow As Long
   Dim b As Integer

   Dim myDicDate As Object
   Dim rsData As Object, rsDate As Object
   
   Const adInteger = 3
   Const adSingle = 4
   Const adDouble = 5
   Const adDate = 7
   Const adVarChar = 200

   On Error GoTo lbl_err
   
   With ThisWorkbook
      Set sh1 = .Sheets(1)
      Set sh2 = .Sheets(2)
   End With
   
   Application.ScreenUpdating = False
   
   'create dictionary
   Set myDicDate = CreateObject("scripting.dictionary")
   'create an ADODB.Recordset and call it rs
   Set rsDate = CreateObject("ADODB.Recordset")
   Set rsData = CreateObject("ADODB.Recordset")
   
   With rsDate.Fields
      .Append "date", adDate
   End With
   
   With rsData.Fields
      .Append "ref", adInteger
      .Append "date", adDate
      .Append "col", adInteger
      .Append "data", adDouble
   End With
   rsDate.Open
   rsData.Open
   
   lastRow = sh1.Cells(Rows.Count, "b").End(xlUp).Row
   For r = 1 To lastRow
      If sh1.Cells(r, 1).Text Like "*/*/*" Then
         myDate = DateSerial(Year(sh1.Cells(r, 1)), Month(sh1.Cells(r, 1)) + 1, 1) - 1
         If Not myDicDate.exists(myDate) Then
            myDicDate.Add Item:="", Key:=myDate
         End If
         For c = 2 To 3
            rsData.addnew
            rsData("ref") = myRef
            rsData("date") = myDate
            rsData("col") = c - 1
            If sh1.Cells(r, c) <> "" Then
               rsData("data") = sh1.Cells(r, c)
            End If
            rsData.Update
         Next c
      Else
         myRef = sh1.Cells(r, 1)
      End If
   Next r
   
   'dates
   sh2.Range("3:" & Rows.Count).ClearContents
   sh2.Range("b2").Resize(, Columns.Count - 1).ClearContents
   nrDates = 0
   For Each elem In myDicDate.keys
      nrDates = nrDates + 1
      rsDate.addnew
      rsDate("date") = CLng(elem)
      rsDate.Update
   Next
   
   'sort date
   rsDate.Sort = "date"
   c = 0
   Do While Not rsDate.EOF
      c = c + 1
      myDicDate(CLng(rsDate("date"))) = c
      sh2.Cells(2, c + 1) = rsDate("date")
      sh2.Cells(2, c + nrDates + 1) = rsDate("date")
      
      rsDate.movenext
   Loop
   
   rsData.Sort = "ref, col, date"
   destRow = 2
   Do While Not rsData.EOF
      myRef = rsData("ref")
      If myRef <> myOldRef Then
         myOldRef = myRef
         destRow = destRow + 1
         sh2.Cells(destRow, 1) = myRef
      End If
      myCol = myDicDate(CLng(rsData("date"))) + 1
      If rsData("col") = 2 Then
         myCol = myCol + nrDates
      End If
      If rsData("data") <> 0 Then
         sh2.Cells(destRow, myCol) = rsData("data")
      End If
      
      rsData.movenext
   Loop
   
   'number formats
   sh2.Range("a3:a" & destRow).NumberFormat = "0"
   sh2.Range("b2").Resize(, nrDates * 2).NumberFormat = "m/d/yyyy"
   sh2.Range("b3:b" & destRow).Resize(, nrDates * 2).NumberFormat = "#,##0.00"
   
   'borders
   For b = 7 To 12
      With sh2.Range("a2:a" & destRow).Resize(, 2 * nrDates + 1).Borders(b)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
      End With
   Next b
   
   'columns autofit
   sh2.Columns.AutoFit
   Application.ScreenUpdating = True
   sh2.Activate
   
   Set myDicDate = Nothing
   Set rsData = Nothing
   Set rsDate = Nothing
   Set sh1 = Nothing
   Set sh2 = Nothing
   
   MsgBox ("Elaboration ended")
   Exit Sub

lbl_err:
   Stop
   Resume Next
End Sub

Regards,
Antonio