Acronym Macro 2

[MSE]

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

 

[Joel]

The code requires two minor changes

from
If .Range("F" & RowCount) <> .Range("F" & (RowCount + 1)) Then
Set NewSht = Worksheets.Add(after:=Sheets(Sheets.Count))
NewSht.Name = .Range("F" & RowCount)
to
If left(.Range("F" & RowCount),4) <> _
left(.Range("F" & (RowCount + 1),4)) Then

Set NewSht = Worksheets.Add(after:=Sheets(Sheets.Count))
NewSht.Name = left(.Range("F" & RowCount),4)

 

[MSE]

Its nice to hear from you again Joel. After I try to run the Marco Excel
jumps to Visual Basic and I am getting a message that reads "compile error
argument not optional".

This part of the code -- Sub Sort_Acronyms() -- turns yellow and has an
arrow pointing next to it.

Then the word "Left" in this part of the code -- Left(.Range("F" &
(RowCount + 1), 4)) Then -- gets highlighted in blue. (I am wondering if
that is an indicator that this part of the code is having an issue)

I assigned the code you advised below to an Excel button from the forms
toolbar.

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 Left(.Range("F" & RowCount), 4) <> _
Left(.Range("F" & (RowCount + 1), 4)) Then

Set NewSht = Worksheets.Add(after:=Sheets(Sheets.Count))
NewSht.Name = Left(.Range("F" & RowCount), 4)
.Rows(FirstRow & ":" & RowCount).Copy _
Destination:=NewSht.Rows(1)
FirstRow = RowCount + 1
End If
RowCount = RowCount + 1
Loop
End With


End Sub

Do you have any thoughts?

 

[Joel]

I had a parenthsis in the wrong place in this line

If Left(.Range("F" & RowCount), 4) <> _
Left(.Range("F" & (RowCount + 1)), 4) Then

 

[MSE]

Joel, you are the man! I am so grateful for your help. The code works
beautifully. There is still one more function, I am not sure if I
communicated clearly, that I am trying to add. I want to copy cells A1
through L1 on Sheet1 and paste them in cells A1 through L1 of each new
worksheet that gets created for the AAAAs, BBBBs, CCCCs, DDDDs, and so on.
Might you be able to help me with that as well?

 

[MSE]

Sorry, I just realized that I forgot to include the present code.

Sincerely,

Eddie

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 Left(.Range("F" & RowCount), 4) <> _
Left(.Range("F" & (RowCount + 1)), 4) Then

Set NewSht = Worksheets.Add(after:=Sheets(Sheets.Count))
NewSht.Name = Left(.Range("F" & RowCount), 4)
.Rows(FirstRow & ":" & RowCount).Copy _
Destination:=NewSht.Rows(1)
FirstRow = RowCount + 1
End If
RowCount = RowCount + 1
Loop
End With


End Sub

 

[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 Left(.Range("F" & RowCount), 4) <> _
Left(.Range("F" & (RowCount + 1)), 4) Then

Set NewSht = Worksheets.Add(after:=Sheets(Sheets.Count))
NewSht.Name = Left(.Range("F" & RowCount), 4)
Sheets("Sheet1").Range("A1:L1").Copy _
Destination:=NewSht.Range("A1")
.Rows(FirstRow & ":" & RowCount).Copy _
Destination:=NewSht.Rows(2)
FirstRow = RowCount + 1
End If
RowCount = RowCount + 1
Loop
End With


End Sub

 

[MSE]

Thank you. The code is perfect. I hope I have successfully communicated how
much I have appreciated your help.