Issues compiling data

[akumar22]

I have information like this in an excel workbook:

Item District
A 12
A 57
A1 455
B 301
B2 411
C 3
C 5
C 71
C2 86
C5 234

In a second workbook I need the information in the following format:
A 12 57
A1 455
B 301
B2 411
C 3 5 71
C2 86
C5 234

The amount of information is very large and I am tired of filtering, copying, transposing and pasting. Is there a more efficient way of doing this. Thank you for your help.

 

[Norie]

What happened to A1?

 

[akumar22]

Sorry, just corrected it.

 

[hiker95]

akumar22,


Sample raw data in worksheet Sheet1:

Excel Workbook
	A	B
1	Item	District
2	A	12
3	A	57
4	A1	455
5	B	301
6	B2	411
7	C	3
8	C	5
9	C	71
10	C2	86
11	C5	234
12
Sheet1

After the macro in a new worksheet Results:

Excel Workbook
	A	B	C	D
1	A	12	57
2	A1	455
3	B	301
4	B2	411
5	C	3	5	71
6	C2	86
7	C5	234
8
Results

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).


1. Copy the below code, by highlighting the code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Option Explicit
Sub ReorgData()
' hiker95, 07/22/2011
' http://www.mrexcel.com/forum/showthread.php?t=566320
' This macro code has been modified from the original code
'   by: mirabeau, 07/08/2011
'   http://www.mrexcel.com/forum/showthread.php?t=563070
Dim w1 As Worksheet, wR As Worksheet
Dim a, na As Long, m As Long, k As Long
Dim c(), p As Long, i As Long
Application.ScreenUpdating = False
Set w1 = Worksheets("Sheet1")
w1.Activate
i = Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:B" & i).Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2") _
  , Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
  Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
a = Range("A1").CurrentRegion.Resize(, 2)
na = UBound(a, 1)
m = 2
k = 1
ReDim c(1 To na, 1 To m)
For i = 2 To na
  If a(i, 1) <> a(i - 1, 1) Then
    k = k + 1
    p = 2
    c(k, 1) = a(i, 1)
    c(k, 2) = a(i, 2)
   Else
    p = p + 1
    If p > m Then
      m = p
      ReDim Preserve c(1 To na, 1 To m)
    End If
  c(k, p) = a(i, 2)
  End If
Next i
c(1, 1) = "Item"
For i = 2 To m
  c(1, i) = "District"
Next i
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wR = Worksheets("Results")
wR.UsedRange.Clear
wR.Activate
With wR.Range("A1").Resize(k, m)
  .Value = c
  .Columns.AutoFit
End With
wR.Rows(1).Delete
Application.ScreenUpdating = True
End Sub

Then run the ReorgData macro.