Macro Assistance - Extra Column Added to Code - Will Not Sort Chronologically Anymore

Justinian

Well-known Member
Joined
Aug 9, 2009
Messages
1,557
Office Version
  1. 365
Platform
  1. Windows
I have a spreadsheet that runs a macro to do the following:

I have a list of employees, thousands of rows. The code looks for the last two digits of the employee numbers and groups them together on separate tabs as follows:


01,44,79
02
05,08
06
07,11
10
13
15
18,30,70
19,19A,26, 26A
20
21
22
23
24
28
29
31
33
34
36
37
43
54
59,89
73
76
78
AA through ZZ

So basically, on the first tab, I have thousands of employee numbers and when I run the macro, tab #2 is all employee numbers ending in 01, 44, and 79; tab 3 is all employee numbers ending in 02, etc. You get the idea. Hiker 95 helped me with the code but my manager changed the report - he added an extra column so the code Hiker wrote works, but it does not place the tabs to the right of the summary tab in chronological order anymore. If I post the code, can someone help me alter it? All that changed is Z is no longer the last column, AA is.

Sub CreateEmployeeNumberSheets()
' hiker95, 08/28/2014, ME800316
Dim ws As Worksheet, en As Worksheet, h As String
Dim c As Range, n As Range, nr As Long
Application.ScreenUpdating = False
Set ws = Sheets("Summary")
Set en = Sheets("EN_Sheets")
With ws
For Each c In .Range("I2", .Range("I" & Rows.Count).End(xlUp))
If Right(c, 2) Like "[0-9][0-9]" Then
Set n = en.Columns(1).Find(Right(c, 2), LookAt:=xlWhole)
If Not n Is Nothing Then
h = en.Cells(n.Row, 2).Value
If Not WorksheetExists(h) Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = h
ws.Range("A1:Z1").Copy Destination:=Sheets(h).Range("A1")
Application.CutCopyMode = False
End If
With Sheets(h)
nr = Sheets(h).Cells(Sheets(h).Rows.Count, "I").End(xlUp).Row + 1
ws.Range("A" & c.Row & ":Z" & c.Row).Copy Destination:=Sheets(h).Range("A" & nr)
Application.CutCopyMode = False
End With
End If
ElseIf Right(c, 3) Like "[0-9][0-9][A-Z]" Then
If Right(c, 3) = "19A" Or Right(c, 3) = "26A" Then
h = "19, 19A, 26, 26A"
If Not WorksheetExists(h) Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = h
End If
With Sheets(h)
ws.Range("A1:Z1").Copy Destination:=Sheets(h).Range("A1")
Application.CutCopyMode = False
nr = Sheets(h).Cells(Sheets(h).Rows.Count, "I").End(xlUp).Row + 1
ws.Range("A" & c.Row & ":Z" & c.Row).Copy Destination:=Sheets(h).Range("A" & nr)
Application.CutCopyMode = False
End With
End If
ElseIf Right(c, 2) Like "[A-Z][A-Z]" Then
h = "AA - ZZ"
If Not WorksheetExists(h) Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = h
End If
With Sheets(h)
ws.Range("A1:Z1").Copy Destination:=Sheets(h).Range("A1")
Application.CutCopyMode = False
nr = Sheets(h).Cells(Sheets(h).Rows.Count, "I").End(xlUp).Row + 1
ws.Range("A" & c.Row & ":Z" & c.Row).Copy Destination:=Sheets(h).Range("A" & nr)
Application.CutCopyMode = False
End With
End If
Next c
End With
Application.ScreenUpdating = True
End Sub
Function WorksheetExists(WSName As String) As Boolean
On Error Resume Next
WorksheetExists = Worksheets(WSName).Name = WSName
On Error GoTo 0
End Function
 
Last edited:

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.
Was that the original code? Or did you change anything to try and make it work?

It looks like there are a couple of places that you need to change in there to maybe make it work. I'm not the greatest at Macros but try.

If it doesn't quite work let me know and I have 1 or 2 more things I would try and change. (Keep the original code too just in case)

Code:
[COLOR=#333333]Sub CreateEmployeeNumberSheets()[/COLOR]
[COLOR=#333333]' hiker95, 08/28/2014, ME800316
[/COLOR]' Updated 09/12/2014, Benzula

[COLOR=#333333]Dim ws As Worksheet, en As Worksheet, h As String[/COLOR]
[COLOR=#333333]Dim c As Range, n As Range, nr As Long[/COLOR]
[COLOR=#333333]Application.ScreenUpdating = False[/COLOR]
[COLOR=#333333]Set ws = Sheets("Summary")[/COLOR]
[COLOR=#333333]Set en = Sheets("EN_Sheets")[/COLOR]
[COLOR=#333333]With ws[/COLOR]
[COLOR=#333333]For Each c In .Range("I2", .Range("I" & Rows.Count).End(xlUp))[/COLOR]
[COLOR=#333333]If Right(c, 2) Like "[0-9][0-9]" Then[/COLOR]
[COLOR=#333333]Set n = en.Columns(1).Find(Right(c, 2), LookAt:=xlWhole)[/COLOR]
[COLOR=#333333]If Not n Is Nothing Then[/COLOR]
[COLOR=#333333]h = en.Cells(n.Row, 2).Value[/COLOR]
[COLOR=#333333]If Not WorksheetExists(h) Then[/COLOR]
[COLOR=#333333]Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = h[/COLOR]
[COLOR=#333333]ws.Range("A1:AA1").Copy Destination:=Sheets(h).Range("A1")[/COLOR]
[COLOR=#333333]Application.CutCopyMode = False[/COLOR]
[COLOR=#333333]End If[/COLOR]
[COLOR=#333333]With Sheets(h)[/COLOR]
[COLOR=#333333]nr = Sheets(h).Cells(Sheets(h).Rows.Count, "I").End(xlUp).Row + 1[/COLOR]
[COLOR=#333333]ws.Range("A" & c.Row & ":AA" & c.Row).Copy Destination:=Sheets(h).Range("A" & nr)[/COLOR]
[COLOR=#333333]Application.CutCopyMode = False[/COLOR]
[COLOR=#333333]End With[/COLOR]
[COLOR=#333333]End If[/COLOR]
[COLOR=#333333]ElseIf Right(c, 3) Like "[0-9][0-9][A-AA]" Then[/COLOR]
[COLOR=#333333]If Right(c, 3) = "19A" Or Right(c, 3) = "26A" Then[/COLOR]
[COLOR=#333333]h = "19, 19A, 26, 26A"[/COLOR]
[COLOR=#333333]If Not WorksheetExists(h) Then[/COLOR]
[COLOR=#333333]Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = h[/COLOR]
[COLOR=#333333]End If[/COLOR]
[COLOR=#333333]With Sheets(h)[/COLOR]
[COLOR=#333333]ws.Range("A1:AA1").Copy Destination:=Sheets(h).Range("A1")[/COLOR]
[COLOR=#333333]Application.CutCopyMode = False[/COLOR]
[COLOR=#333333]nr = Sheets(h).Cells(Sheets(h).Rows.Count, "I").End(xlUp).Row + 1[/COLOR]
[COLOR=#333333]ws.Range("A" & c.Row & ":AA" & c.Row).Copy Destination:=Sheets(h).Range("A" & nr)[/COLOR]
[COLOR=#333333]Application.CutCopyMode = False[/COLOR]
[COLOR=#333333]End With[/COLOR]
[COLOR=#333333]End If[/COLOR]
[COLOR=#333333]ElseIf Right(c, 2) Like "[A-AA][A-AA]" Then[/COLOR]
[COLOR=#333333]h = "AA - ZZ"[/COLOR]
[COLOR=#333333]If Not WorksheetExists(h) Then[/COLOR]
[COLOR=#333333]Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = h[/COLOR]
[COLOR=#333333]End If[/COLOR]
[COLOR=#333333]With Sheets(h)[/COLOR]
[COLOR=#333333]ws.Range("A1:AA1").Copy Destination:=Sheets(h).Range("A1")[/COLOR]
[COLOR=#333333]Application.CutCopyMode = False[/COLOR]
[COLOR=#333333]nr = Sheets(h).Cells(Sheets(h).Rows.Count, "I").End(xlUp).Row + 1[/COLOR]
[COLOR=#333333]ws.Range("A" & c.Row & ":AA" & c.Row).Copy Destination:=Sheets(h).Range("A" & nr)[/COLOR]
[COLOR=#333333]Application.CutCopyMode = False[/COLOR]
[COLOR=#333333]End With[/COLOR]
[COLOR=#333333]End If[/COLOR]
[COLOR=#333333]Next c[/COLOR]
[COLOR=#333333]End With[/COLOR]
[COLOR=#333333]Application.ScreenUpdating = True[/COLOR]
[COLOR=#333333]End Sub[/COLOR]
[COLOR=#333333]Function WorksheetExists(WSName As String) As Boolean[/COLOR]
[COLOR=#333333]On Error Resume Next[/COLOR]
[COLOR=#333333]WorksheetExists = Worksheets(WSName).Name = WSName[/COLOR]
[COLOR=#333333]On Error GoTo 0[/COLOR]
[COLOR=#333333]End Function
[/COLOR]
 
Upvote 0
Thank you for the quick reply.

It is the original code and it is still running but not putting the tabs in order anymore. I cannot figure out why it is doing this.
 
Upvote 0
Try this one

Code:
Sub CreateEmployeeNumberSheets()
' hiker95, 08/28/2014, ME800316
' Updated 09/12/2014, Benzula


Dim ws As Worksheet, en As Worksheet, h As String
Dim c As Range, n As Range, nr As Long
Application.ScreenUpdating = False
Set ws = Sheets("Summary")
Set en = Sheets("EN_Sheets")
With ws
For Each c In .Range("I2", .Range("I" & Rows.Count).End(xlUp))
If Right(c, 2) Like "[0-9][0-9]" Then
Set n = en.Columns(1).Find(Right(c, 2), LookAt:=xlWhole)
If Not n Is Nothing Then
h = en.Cells(n.Row, 2).Value
If Not WorksheetExists(h) Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = h
ws.Range("A1:AA1").Copy Destination:=Sheets(h).Range("A1")
Application.CutCopyMode = False
End If
With Sheets(h)
nr = Sheets(h).Cells(Sheets(h).Rows.Count, "I").End(xlUp).Row + 1
ws.Range("A" & c.Row & ":AA" & c.Row).Copy Destination:=Sheets(h).Range("A" & nr)
Application.CutCopyMode = False
End With
End If
ElseIf Right(c, 3) Like "[0-9][0-9][A-AA]" Then
If Right(c, 3) = "19A" Or Right(c, 3) = "26A" Then
h = "19, 19A, 26, 26A"
If Not WorksheetExists(h) Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = h
End If
With Sheets(h)
ws.Range("A1:AA1").Copy Destination:=Sheets(h).Range("A1")
Application.CutCopyMode = False
nr = Sheets(h).Cells(Sheets(h).Rows.Count, "I").End(xlUp).Row + 1
ws.Range("A" & c.Row & ":AA" & c.Row).Copy Destination:=Sheets(h).Range("A" & nr)
Application.CutCopyMode = False
End With
End If
ElseIf Right(c, 2) Like "[A-AA][A-AA]" Then
h = "AB - ZZ"
If Not WorksheetExists(h) Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = h
End If
With Sheets(h)
ws.Range("A1:AA1").Copy Destination:=Sheets(h).Range("A1")
Application.CutCopyMode = False
nr = Sheets(h).Cells(Sheets(h).Rows.Count, "I").End(xlUp).Row + 1
ws.Range("A" & c.Row & ":AA" & c.Row).Copy Destination:=Sheets(h).Range("A" & nr)
Application.CutCopyMode = False
End With
End If
Next c
End With
Application.ScreenUpdating = True
End Sub
Function WorksheetExists(WSName As String) As Boolean
On Error Resume Next
WorksheetExists = Worksheets(WSName).Name = WSName
On Error GoTo 0
End Function
 
Last edited:
Upvote 0
No, it is starting with 34, then 18 / 30 / 70, then 20, then 01, etc.
 
Upvote 0
Oh! Where was the new column added? At the end or in the middle of the worksheet? If it is in the middle, then the reference column prolly got shifted. Try moving the new added column to the end and see if it works. (Any of the 3, Original, and my two altered ones.)
 
Upvote 0
The new column was added to the end, so the last column is now AA instead of Z.
 
Upvote 0
Okay,

Try this one. This is my last attempt. I've put notes to what I think each section of code is doing too.

Code:
Sub CreateEmployeeNumberSheets()
' hiker95, 08/28/2014, ME800316

‘ Setting Parameters
Dim ws As Worksheet, en As Worksheet, h As String
Dim c As Range, n As Range, nr As Long
Application.ScreenUpdating = False
Set ws = Sheets("Summary")
Set en = Sheets("EN_Sheets")

‘Action on Summary Sheet
With ws
For Each c In .Range("I2", .Range("I" & Rows.Count).End(xlUp))

‘Saying If the right 2 most digits are any numbers 0-9
If Right(c, 2) Like "[0-9][0-9]" Then

‘Action on “EN_Sheets (Setting up range of sheet)
Set n = en.Columns(1).Find(Right(c, 2), LookAt:=xlWhole)
If Not n Is Nothing Then
h = en.Cells(n.Row, 2).Value
If Not WorksheetExists(h) Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = h
ws.Range("A1:AA1").Copy Destination:=Sheets(h).Range("A1")
Application.CutCopyMode = False
End If

‘Copying numbers that end in just two digits to new sheet
With Sheets(h)
nr = Sheets(h).Cells(Sheets(h).Rows.Count, "I").End(xlUp).Row + 1
ws.Range("A" & c.Row & ":AA" & c.Row).Copy Destination:=Sheets(h).Range("A" & nr)
Application.CutCopyMode = False
End With
End If

‘Setting up range for 2digits+number
ElseIf Right(c, 3) Like "[0-9][0-9][A-Z]" Then
If Right(c, 3) = "19A" Or Right(c, 3) = "26A" Then
h = "19, 19A, 26, 26A"
If Not WorksheetExists(h) Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = h
End If

‘Copying over to new sheet
With Sheets(h)
ws.Range("A1:AA1").Copy Destination:=Sheets(h).Range("A1")
Application.CutCopyMode = False
nr = Sheets(h).Cells(Sheets(h).Rows.Count, "I").End(xlUp).Row + 1
ws.Range("A" & c.Row & ":AA" & c.Row).Copy Destination:=Sheets(h).Range("A" & nr)
Application.CutCopyMode = False
End With
End If

‘Setting up range for double letters ones
ElseIf Right(c, 2) Like "[A-Z][A-Z]" Then
h = "AA - ZZ"
If Not WorksheetExists(h) Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = h
End If

‘Copying over double letter ones to new sheet
With Sheets(h)
ws.Range("A1:AA1").Copy Destination:=Sheets(h).Range("A1")
Application.CutCopyMode = False
nr = Sheets(h).Cells(Sheets(h).Rows.Count, "I").End(xlUp).Row + 1
ws.Range("A" & c.Row & ":AA" & c.Row).Copy Destination:=Sheets(h).Range("A" & nr)
Application.CutCopyMode = False
End With
End If
Next c
End With
Application.ScreenUpdating = True
End Sub
Function WorksheetExists(WSName As String) As Boolean
On Error Resume Next
WorksheetExists = Worksheets(WSName).Name = WSName
On Error GoTo 0
End Function
 
Upvote 0

Forum statistics

Threads
1,226,532
Messages
6,191,609
Members
453,667
Latest member
JoeH7745

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top