Help!

[florin1]

Hello! I need to transpose some data from columns to rows like in the example below using VBA. It seems simple but for me, a beginner, it is a little bit difficult.

A 3
B 2
B 8
A 6
B 1

to:

A 3 6
B 2 8 1

I really hope that someone can help me!

 

[hiker95]

florin1,

Your workbook will have to contain worksheets data, and, personal.

The following macro is a combination of your macro and my macro.

The below macro will also add the formulae in worksheet personal.

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Sub ReorgDataV3()
' hiker95, 05/25/2014, ME780017
Dim oa As Variant
Dim r As Long, lr As Long, nr As Long, nc As Long, n As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Workbooks("a").Activate
Sheets("data").Activate
Range("A2:A10000").Select
Selection.Copy
Sheets("personal").Activate
Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.Range("$B$1:$B$501").RemoveDuplicates Columns:=1, Header:=xlNo
With Sheets("personal")
  lr = .Cells(Rows.Count, 2).End(xlUp).Row
  With .Range("A1:A" & lr)
    .Formula = "=IFERROR(INDEX(data!D:D,MATCH(personal!B1,data!A:A,0)),"""")"
  End With
  oa = .Range("A1:B" & lr)
  With .Range("A1:A" & lr)
    .Value = .Value
  End With
  .Range("A1:B" & lr).Sort key1:=Range("A1"), order1:=1
  nr = 0
  For r = 1 To lr
    n = Application.CountIf(.Columns(1), .Cells(r, 1).Value)
    If n = 1 Then
      nr = nr + 1
      .Cells(nr, 4).Resize(, 2).Value = .Cells(r, 1).Resize(, 2).Value
    ElseIf n > 1 Then
      nr = nr + 1
      .Cells(nr, 4).Value = .Cells(r, 1).Value
      .Cells(nr, 5).Resize(, n).Value = Application.Transpose(.Range("B" & r & ":B" & r + n - 1).Value)
    End If
    r = r + n - 1
  Next r
  .Range("A1:B" & lr) = oa
  With .Range("A1:A" & lr)
    .Formula = "=IFERROR(INDEX(data!D:D,MATCH(personal!B1,data!A:A,0)),"""")"
  End With
  .Columns.AutoFit
  .Activate
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReorgDataV3 macro.

 

[florin1]

Thank you very much for your help, it is working now!
I can now finish my report!
Thank you!

 

[hiker95]

florin1,

Thanks for the feedback.

You are very welcome. Glad I could help.

And, come back anytime.