Help modifying a macro

[lwilt]

I'm trying to modify a macro for transposing some data and it's not working. Here is the original macro:

Sub TransposeQandP()
Dim X As Long, Ar As Range
With Range("A1:A" & Cells(Rows.Count, "B").End(xlUp).Row).SpecialCells(xlBlanks)
For Each Ar In .Areas
For X = 1 To Ar.Count
Ar(1).Offset(-1, Cells(Ar(1).Offset(-1).Row, Columns.Count).End(xlToLeft). _
Column).Resize(, 2).Value = Ar(1).Offset(X - 1, 2).Resize(, 2).Value
Next
Next
.EntireRow.Delete
End With
End Sub

Now my data set is only 2 columns where I need to transpose what is in column B so that each different entry in column A will have every entry attached to in in column B all being in one single row.

please help...thank you

 

[Rolstoelkid]

Sub()
Max = application.count("A:A")

For i = 1 To max
If Cells(i, 1) <> "" Then
matchFound = WorksheetFunction.Match(Cells(i, 1), Range("A1:A" & max), 0)
If i <> matchFound Then
worksheet.range(cells(i, 2), cells(i, max+1)).formulaArray = "=transpose(r1c[-1]:r" & max & "c[-1]")"
End If
End If
Next
End Sub

That'll sort out the transpose part. Regarding the duplicate values in A, im not really sure about it.

 

[NARAYANK991]

Hi ,

Try this :

Sub TransposeQandP()
    Dim X As Long
    Dim Ar As Range, OutputCell as Range
 
    Application.ScreenUpdating = False

    With Range("A1:A" & Cells(Rows.Count, "B").End(xlUp).Row).SpecialCells(xlBlanks)
         For Each Ar In .Areas
             Set OutputCell = Ar.Offset(-1, 2).Resize(1, 1)
             Ar.Offset(, 1).Copy
             OutputCell.PasteSpecial xlPasteValues, , , True
         Next
         .EntireRow.Delete
    End With

    Application.ScreenUpdating = True
End Sub

or this :

Sub TransposeQandP()
    Dim X As Long
    Dim Ar As Range, OutputCell As Range
 
    Application.ScreenUpdating = False
 
    With Range("A1:A" & Cells(Rows.Count, "B").End(xlUp).Row).SpecialCells(xlBlanks)
         For Each Ar In .Areas
             Set OutputCell = Ar.Offset(-1, 2).Resize(1, 1)
             OutputCell.Resize(1, Ar.Cells.Count).FormulaArray = Application.WorksheetFunction.Transpose(Ar.Offset(, 1).Value)
         Next
         .EntireRow.Delete
    End With
 
    Application.ScreenUpdating = True
End Sub

Narayan

 

[lwilt]

I will give it a shot....thanks guys