Macro to pull data with criterea for placement on a new sheet

[Trina]

I have a worksheet with 2 colums. The rating column will contain 1 of 9
scores. There are about 50 data lines. I need to goup them by that score in
a new worksheet in a block format. I added the example and look of finished
product I need. Can a macro or Excel function make this work?

Data Worksheet:
Rating Name
1A Smith
1A Jerry
2A Jones
3A Daye
1B Wilson
2B Johnson
2B Wint
3B Lager
1C Swith
2C Jackson
3C Cole


Output Worksheet
__________________________________________________________________
|All 1C listed here | All 1B listed here | All
1A listed here |
| Swith | Wilson |
Smith |
| | |
Jerry |
|__________________|______________________|_______________________|
|All 2C listed here | All 2B listed here | All
2A listed here |
| Jackson | Johnson |
Jones |
| | Wint |
|
|__________________|______________________|_______________________|
|All 3C listed here | All 3B listed here | All
3A listed here |
| Cole | Lager |
Daye |
|__________________|______________________|_______________________|

 

[Otto Moehrbach]

Trina
A Pivot Table might work for you. Look it up in Help. If not, the
following macro will do it for you. I chose "Sheet2" as the name of the
second or destination sheet. The sheet that holds the original 2 columns (A
& B in this macro) must be the active sheet when you run this macro. Look
at the Select Case part of the macro. The letters that follow the word
Case are your ratings. Type in your ratings in place of what I have. The
numbers following TheCol= are the column numbers in the second sheet in
which the macro will place the names. A 1 is Column A, a 2 is Column B, and
so on. HTH Otto
Sub ShuffleData()
Dim rColB As Range
Dim i As Range
Dim TheCol As Long
Set rColB = Range("B2", Range("B" & Rows.Count).End(xlUp))
For Each i In rColB
Select Case i.Offset(, -1).Value
Case "A": TheCol = 1
Case "B": TheCol = 2
Case "C": TheCol = 3
Case "D": TheCol = 4
Case "E": TheCol = 5
Case "F": TheCol = 6
Case "G": TheCol = 7
Case "H": TheCol = 8
Case "I": TheCol = 9
End Select
With Sheets("Sheet2")
.Cells(Rows.Count, TheCol).End(xlUp).Offset(1).Value =
i.Value
End With
Next i
End Sub

 

[Trina]

WOW! This is GREAT. I was able to make it work. I wanted to see if I
chould designate the Select Case locations to be a specifc column and row and
not sure how to modify the code. Can that be done?

 

[Otto Moehrbach]

Trina
As written you can change the destination column, but the destination
row will always be the next empty row in whatever column it goes into. Tell
me more about what you want when you say "a specific column and row". Give
me a couple of examples. Specifically, tell me how you would determine what
column and row you want as the destination. Otto

 

[Trina]

I need the end data to be in a 3 x 3 grid:

1C Data 1B Data 1A Data

2C Data 2B Data 2A Data

2C Data 2B Data 2A Data

 

[Otto Moehrbach]

Trina
I understand the 3x3 grid since there are only 9 ratings. What I don't
know is how many rows do you want to reserve in each rating. To be more
exact, how many rows in the top 3 ratings and how many rows in the second 3
ratings. Or maybe you want the code to figure that out. In that case, do
you want any blank rows (how many?) between the upper 3 and the middle 3 and
the lower 3? Otto

 

[Trina]

I would like the code to figure out how many rows will be needed. Ideally, I
would like 3 blank rows in between the top & middle and middle & bottom.

Thanks for all your help!!

 

[Otto Moehrbach]

Trina

Here it is. I chose "New Sheet" as the name of the destination
sheet. That name is in the code. Go into the code and find that name (it's
in only one place) and change it to match what you have.

IMPORTANT: This code will clear EVERY cell in the "New Sheet" sheet before
it copies the data to it. If you have data in that sheet that you want to
keep, let me know where it is and I'll change the code accordingly. The
macro will place the data and headers in the destination sheet as you stated
in your last post.

This macro will paste the data into Columns A:C starting in row 1.

This macro assumes your data in the first sheet is in columns A:B starting
in row 2 with headers in row 1.

If you run into errors, they may be because of line wrapping in this post.
The code will not tolerate line wrapping. If you wish, send me an email and
I'll send you the small file I used to develop the code. It will have the
code properly placed. My email address is (e-mail address removed).
Remove the "extra" from this address. Otto

Sub ShuffleData2()
Dim rColA As Range, Rating As Variant, Dest As Range
Dim rColACopy As Range
Dim rFirst1C As Range, rFirst2C As Range, rFirst3C As Range
Dim NumRow1 As Long, NumRow2 As Long
Set rColA = Range("A1", Range("A" & Rows.Count).End(xlUp))
NumRow1 = Application.Max(Application.CountIf(rColA, "1C"), _
Application.CountIf(rColA, "1B"), Application.CountIf(rColA,
"1A"))
NumRow2 = Application.Max(Application.CountIf(rColA, "2C"), _
Application.CountIf(rColA, "2B"), Application.CountIf(rColA,
"2A"))
With Sheets("New Sheet")
.Cells.ClearContents
Set rFirst1C = .Range("A2")
Set rFirst2C = rFirst1C.Offset(NumRow1 + 4)
Set rFirst3C = rFirst2C.Offset(NumRow2 + 4)
.Range("A1").Value = "1C Data"
.Range("B1").Value = "1B Data"
.Range("C1").Value = "1A Data"
rFirst2C.Offset(-1) = "2C Data"
rFirst2C.Offset(-1, 1) = "2B Data"
rFirst2C.Offset(-1, 2) = "2A Data"
rFirst3C.Offset(-1) = "3C Data"
rFirst3C.Offset(-1, 1) = "3B Data"
rFirst3C.Offset(-1, 2) = "3A Data"
Set rColACopy = Range(rColA(2), rColA(rColA.Count))
Application.ScreenUpdating = False
For Each Rating In Array("1A", "1B", "1C", "2A", "2B", "2C",
"3A", "3B", "3C")
Select Case Rating
Case "1A": Set Dest = rFirst1C.Offset(, 2)
Case "1B": Set Dest = rFirst1C.Offset(, 1)
Case "1C": Set Dest = rFirst1C
Case "2A": Set Dest = rFirst2C.Offset(, 2)
Case "2B": Set Dest = rFirst2C.Offset(, 1)
Case "2C": Set Dest = rFirst2C
Case "3A": Set Dest = rFirst3C.Offset(, 2)
Case "3B": Set Dest = rFirst3C.Offset(, 1)
Case "3C": Set Dest = rFirst3C
End Select
If Not rColACopy.Find(What:=Rating, LookAt:=xlWhole) Is
Nothing Then
rColA.Resize(, 2).AutoFilter
rColA.Resize(, 2).AutoFilter Field:=1,
Criteria1:=Rating
rColACopy.Offset(,
1).SpecialCells(xlCellTypeVisible).Copy Dest
rColA.Resize(, 2).AutoFilter
End If
Next Rating
Application.ScreenUpdating = True
End With
End Sub