Thread: Acronym Macro 2
View Single Post
  #1   Report Post  
Posted to microsoft.public.excel.programming
MSE MSE is offline
external usenet poster
 
Posts: 15
Default Acronym Macro 2

I have a Macro linked to an Excel button from the forms toolbar, thanks Joel.
The code is at the bottom of this post and it already performs the following
functions.

1. Copies the entire contents of rows in Sheet 1 from A2 to L30.

2. Sort all the contents of rows 2 through 30 based on the acronyms AAAA,
BBBB, CCCC, DDDD, & EEEE and group the AAAA with the AAAA, the BBBB with
the BBBB, and so on. (The acronyms are located in Column F rows F2
through F30).

3. Create and name a new worksheet for all the AAAA, BBBB, CCCC, DDDD, &
EEEE.

4. Paste all the contents of rows A through L containing AAAA in Sheet
AAAA, all the contents of the rows A through L containing BBBB in Sheet
BBBB, all the contents of rows A through L containing CCCC in Sheet CCCC,
and so on.

Now, I am trying to add the following functions to the code.

1. Sort all the contents of rows 2 through 30 based on the first four
letters of each acronym in Column F and then group them together. As a
result AAAA1 will be grouped with AAAA2, AAAA3, & AAAA4 on the same
worksheet and that worksheet will be named AAAA. BBBB1 will be grouped
with BBBB2,BBBB3, & BBBB4 on the same worksheet and that worksheet will
be named BBBB. CCCC1 will be grouped with CCCC2, CCCC3, and CCCC4 on the
same worksheet and that worksheet will be named CCCC and so on.

2. Copy and paste cells A1 through L1 from Sheet 1 into cells A1 through L1

of each new worksheet that is created for all the AAAAs,
BBBBs, CCCCs, and so on.

Do you have any ideas about how I might be able to make this happen?

Original Code is as follows, much thanks to Joel.
Sub Sort_Acronyms()

With Sheets("Sheet1")
Set ShortSht = Worksheets.Add(after:=Sheets(Sheets.Count))
ShortSht.Name = "Sort Data"
.Range("A2:L30").Copy Destination:=ShortSht.Range("A1")
End With
With ShortSht
.Range("A1:L30").Sort _
Key1:=Range("F1"), _
Header:=xlNo

RowCount = 1
FirstRow = RowCount
Do While RowCount <= 30
If .Range("F" & RowCount) < .Range("F" & (RowCount + 1)) Then
Set NewSht = Worksheets.Add(after:=Sheets(Sheets.Count))
NewSht.Name = .Range("F" & RowCount)
.Rows(FirstRow & ":" & RowCount).Copy _
Destination:=NewSht.Rows(1)
FirstRow = RowCount + 1
End If
RowCount = RowCount + 1
Loop
End With


End Sub