Transpose Data from Macro

[Abhijeet]

I have data in excel in that few Codes like A,B,D.... i want if below the code any number then that Code & Emp Id data.Data range is not fix so please give dynamic range in macro. In attach file i have mention what type of data and expected result.

 

[Luke M]

Hi Abhijeet,

Excellent problem description, and good example showing current setup + desired outcome. Thank you!

Sub ExtractData()
Dim wsOutput As Worksheet, wsInput As Worksheet
Dim lastRow As Long, recRow As Long
Dim empID As Variant
Dim xCode As String
Dim xUnit As Double
Dim empRange As Range, unitRange As Range, c As Range, d As Range

'Which sheets are we dealing with?
Set wsOutput = Worksheets("Sheet2")
Set wsInput = Worksheets("Sheet1")

'Where do we start output? First line adds on to existing data, second clears previous
'Choose which one you want
recRow = wsOutput.Cells(Rows.Count, "A").End(xlUp).Row + 1
'wsOutput.Range("A2:A10000").ClearContents: recRow = 2

With wsInput
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    'Only want to search cells with values
    On Error Resume Next
    Set empRange = .Range("A2:A" & lastRow).SpecialCells(xlCellTypeConstants)
    On Error GoTo 0
   
    'Error check
    If empRange Is Nothing Then
        MsgBox "No user id's listed", vbOKOnly, "Error"
        Exit Sub
    End If
   
    Application.ScreenUpdating = False
    For Each c In empRange
        Set unitRange = Nothing
        'Check if any units listed
        On Error Resume Next
        Set unitRange = c.Offset(1, 0).EntireRow.SpecialCells(xlCellTypeConstants, xlNumbers)
        On Error Resume Next
        If Not unitRange Is Nothing Then
            empID = c.Value
            For Each d In unitRange
                'What are all our values?
                xCode = d.Offset(-1, 0).Value
                xUnit = d.Value
               
                'Give output
                wsOutput.Cells(recRow, "A").Value = empID
                wsOutput.Cells(recRow, "B").Value = xCode
                wsOutput.Cells(recRow, "C").Value = xUnit
                recRow = recRow + 1
            Next d
        End If
    Next c
    Application.ScreenUpdating = True
End With

End Sub

 

[Abhijeet]

Thanks Luke M It work Fine i will check with my Original Data 2moro in Company and get back to you but this data is working fine thanks again