Transpose Rows to Columns with Blanks cells

[GB]

Hi, I would appreciate some help with what should be a simple macro for some people. In the attachment I have 2 worksheets, named "Was", "Now".

In Was you will find a staff number and all their associated dates to the right. What I need to do is transpose all the dates (ignoring all the blank cells) for each staff number into a Date column and show the corresponding staff number next to the date. You will see an example of the 1st two staff numbers and their dates in the "Now" worksheet which is what I want to achieve.

I would love to know how you do this with some vba. Much appreciated.
regards
GB

 

[shrivallabha]

Please test below code:

Public Sub TranspWithoutBlanks()
Dim i As Long, j As Long, cnt As Long
Sheets("Now").Range("A1:B1").EntireColumn.Delete xlToRight
Sheets("Now").Range("A1:B1").Value = Array("Staff", "Dates")
cnt = 2
Application.ScreenUpdating = False
For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
    For j = 2 To Cells(1, Columns.Count).End(xlToLeft).Column
        If IsDate(Cells(i, j).Value) Then
            Cells(i, "A").Copy Sheets("Now").Cells(cnt, "A")
            Cells(i, j).Copy Sheets("Now").Cells(cnt, "B")
            cnt = cnt + 1
        End If
    Next
Next i
Application.ScreenUpdating = True
End Sub

 

[Ramesh]

Try the following code:

Dim srclastrow As Long
Dim outputcurrentrow As Long
Dim noofrows As Integer
Dim outputlastrow As Long
Dim currentrow As Long
Dim nonblankcells As Range
Dim cell As Range
Dim srcws As Worksheet
Dim outputws As Worksheet

Dim srclastcol As Integer
Sub TrasnsposeData()
    Set srcws = ThisWorkbook.Worksheets("Was")
    Set outputws = ThisWorkbook.Worksheets("Now")
   
    srclastrow = srcws.Range("A" & Cells.Rows.Count).End(xlUp).Row
    srclastcol = srcws.Range("A1").End(xlToRight).Column
   
    outputws.Cells.Clear
    outputws.Range("A1").Value = "Staff"
    outputws.Range("B1").Value = "Dates"
   
    For currentrow = 2 To srclastrow
        srcws.Activate
        If WorksheetFunction.CountBlank(srcws.Range(Cells(currentrow, 2), Cells(currentrow, srclastcol))) <> srclastcol - 1 Then
            outputcurrentrow = outputws.Range("B" & Cells.Rows.Count).End(xlUp).Row + 1
            Set nonblankcells = srcws.Range(Cells(currentrow, 2), Cells(currentrow, srclastcol)).SpecialCells(xlCellTypeConstants, xlNumbers)
           
            outputws.Activate
            If nonblankcells.Cells.Count > 0 Then
                outputws.Range("A" & outputcurrentrow).Value = srcws.Range("A" & currentrow).Value
               
                For Each cell In nonblankcells
                    If Trim(cell.Value) <> "" Then
                        outputws.Range("A" & outputcurrentrow).Value = srcws.Range("A" & currentrow).Value
                        outputws.Range("B" & outputcurrentrow).Value = cell.Value
                        outputcurrentrow = outputcurrentrow + 1
                    End If
                Next
            End If
        End If
    Next
    MsgBox "Done"
End Sub