Help with macro to transpose data

Dear all

i have been tasked to transpose data to columns. at the end of a given month two values are subtracted from a member's portion. each member has a unique reference.

Please note:

1. that some members had nothing subtracted for some months.
2. the resultant data will be such that each member will occupy one row, with values per month in different columns. after values from column B, then values from column C start (the columns will be labeled respectively
3. Ref number are highlighted in yellow for the first few members. Please ignore the totals in the same rows as the Ref numbers.

The data is attached here. and the format i am expecting after running the macro is in "sheet 1" for the first few members.

Your help will be greatly appreciated

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

Different method

Sub test()
    Dim a, b, i As Long, ii As Long, n As Long, t As Long, e
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    a = Sheets("data").Cells(1).CurrentRegion.Value
    t = 1: n = 1
    For i = 1 To UBound(a, 1) - 1
        If IsDate(a(i, 1)) Then
            If Not dic.exists(a(i, 1)) Then
                t = t + 1
                dic(a(i, 1)) = t
            End If
        Else
            n = n + 1
        End If
    Next
    ReDim b(1 To n, 1 To t * 2 - 1)
    b(1, 1) = "Ref Number": n = 1
    For Each e In dic
        b(1, dic(e)) = e
        b(1, dic(e) + dic.Count) = e
    Next
    For i = 1 To UBound(a, 1) - 1
        If Not IsDate(a(i, 1)) Then
            n = n + 1: b(n, 1) = a(i, 1)
        Else
            If n > 0 Then
                b(n, dic(a(i, 1))) = a(i, 2)
                b(n, dic(a(i, 1)) + dic.Count) = a(i, 3)
            End If
        End If
    Next
    With Sheets(2).Range("a2").Resize(n, UBound(b, 2))
        .CurrentRegion.Clear
        .Value = b
        .Columns(2).Resize(, dic.Count).Sort key1:=.Rows(1) _
            , order1:=1, Orientation:=xlLeftToRight
        .Columns(2 + dic.Count).Resize(, dic.Count).Sort _
            key1:=.Rows(1), order1:=1, Orientation:=xlLeftToRight
        .Columns.AutoFit
        .Borders.Weight = 2
        .Parent.Activate
    End With
     Set dic = Nothing
End Sub

you guys are geniuses. Antoka's code worked perfectly while Jindon's worked for some months. You just made my life easier and thank you so much

This forum is a must visit