Need someone with XL2003 to check some code please

yytsunamiyy

Well-known Member
Joined
Mar 17, 2008
Messages
963
Hi Guys,

I have written the following code in XL2007 to copy lists of names and some other information (B2:G - last row of data) from some sheets to a summary sheet ("Gesamt"), order alphabetically, strip headers from sorted List and separate into alphabetical blocs for my gf to use at work. Trouble is, she has 2003 there and hasn't got the foggiest about vba, so any error messages are meaningles to her. Trouble is, I can't troubleshoot the code by phone while she's at work, so I'm looking for someone with a copy of 2003 or lower to give the code a whirl and iron out the bugs. The code runs fine in '07.

The spreadsheet layout:
Excel Workbook
ABCDEFG
1Gsteliste SEA CLOUD, Mittwoch 04.05., HamburgGruppe A
2
3Dehlbrck
4
5Lfd. Nr.NameVornamePersonalausweisGruppeBesucherzeitKontakt
61SCHLICHTPetraxxxxxxxxxxxGruppe A10:30Dehlbrck
72BAHNSENUwexxxxxxxxxxxGruppe A10:30Dehlbrck
83BAHNSENAngelikaxxxxxxxxxxxGruppe A10:30Dehlbrck
94CLAUSManfredxxxxxxxxxxxGruppe A10:30Dehlbrck
105SCHMOLL-CLAUSElonaxxxxxxxxxxxGruppe A10:30Dehlbrck
116KERNKarlxxxxxxxxxxxGruppe A10:30Dehlbrck
127BEYERMichaelaGruppe A10:30Dehlbrck
Gruppe A


The code:

Code:
Option Explicit

Sub Copy_Sort()
Dim sh As Worksheet
Dim Workrow As Long
Dim i As Long


Application.EnableEvents = False
Application.ScreenUpdating = False

'Clear summary sheet
ThisWorkbook.Sheets("Gesamt").Cells.Delete

'Loop through relevant sheets and copy information to Summary sheet "Gesamt"
For Each sh In ThisWorkbook.Sheets
    If sh.Name Like "Gruppe*" Or sh.Name Like "Supplier" Or sh.Name Like "Permanent" Then
        With sh
            .Range(.Cells(6, 2), .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 7)).Copy
        End With
        With ThisWorkbook.Sheets("Gesamt")
            .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row + 1, 2).PasteSpecial xlValues
        End With
        Application.CutCopyMode = False
    End If
Next sh

'alpha sort on Last Name (Col B - Name), First Name (Col C - Vorname)
With ThisWorkbook.Sheets("Gesamt").Sort

    .SortFields.Clear
    .SetRange Range(ThisWorkbook.Sheets("Gesamt").Cells(1, 2), ThisWorkbook.Sheets("Gesamt").Cells(ThisWorkbook.Sheets("Gesamt").Cells(ThisWorkbook.Sheets("Gesamt").Rows.Count, 2).End(xlUp).Row, 7))
    .SortFields.Add Key:=Range(ThisWorkbook.Sheets("Gesamt").Cells(1, 2), ThisWorkbook.Sheets("Gesamt").Cells(ThisWorkbook.Sheets("Gesamt").Cells(ThisWorkbook.Sheets("Gesamt").Rows.Count, 2).End(xlUp).Row, 2)) _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SortFields.Add Key:=Range(ThisWorkbook.Sheets("Gesamt").Cells(1, 3), ThisWorkbook.Sheets("Gesamt").Cells(ThisWorkbook.Sheets("Gesamt").Cells(ThisWorkbook.Sheets("Gesamt").Rows.Count, 2).End(xlUp).Row, 3)) _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
        
End With


With ThisWorkbook.Sheets("Gesamt")
    'Find copied header rows in alpha-sorted list, copy to Row 1 to have headers over sorted list, delete header row from sortet list
    Do While Not .Range(.Cells(2, 2), .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 2)).Find(What:="Name", After:=.Cells(2, 2), LookAt:=xlWhole, searchdirection:=xlPrevious) Is Nothing
                    
        Workrow = .Range(.Cells(2, 2), .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 2)).Find(What:="Name", After:=.Cells(2, 2), LookAt:=xlWhole, searchdirection:=xlPrevious).Row
        If Workrow > 1 Then
            .Range(.Cells(Workrow, 2), .Cells(Workrow, 7)).Copy Destination:=.Cells(1, 2)
            .Cells(Workrow, 2).EntireRow.Delete
        End If
    Loop
    'Set Col F to timeformat h:mm
    With .Range(.Cells(2, 6), .Cells(.Cells(.Rows.Count, 6).End(xlUp).Row, 6))
        .NumberFormat = "h:mm;@"
        .HorizontalAlignment = xlCenter
    End With
    
    'fill continous dataset number in Col A
    .Cells(2, 1).Value = 1
    .Cells(2, 1).AutoFill Destination:=.Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 6).End(xlUp).Row, 1)), Type:=xlFillSeries
    
    'delete extranous lines that have been copied but do not contain names
    .Range(.Cells(.Cells(.Rows.Count, 2).End(xlUp).Row + 1, 2), .Cells(.Cells(.Rows.Count, 6).End(xlUp).Row, 6)).EntireRow.Delete
    
    'insert empty row above each block of lastnames starting with the same letter, write said letter in Col B, mark Bold
    For i = .Cells(.Rows.Count, 2).End(xlUp).Row To 2 Step -1
        If Left(.Cells(i, 2), 1)<> Left(.Cells(i - 1, 2), 1) Then
            .Cells(i, 2).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            .Cells(i, 2).Value = Left(.Cells(i + 1, 2), 1)
            .Cells(i, 2).Font.Bold = True
        End If
    
    Next i
    .Cells(1, 1).Value = "Lfd. Nr."
    .Range(.Cells(1, 1), .Cells(1, 7)).Font.Bold = True
    
End With



Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

The output:
Excel Workbook
ABCDEFG
1Lfd. Nr.NameVornamePersonalausweisGruppeBesucherzeitKontakt
2A
31AMMERMANNSilkepermanent08:00-18:00SCC
42ASMUSSENSoerenpermanent08:00-18:00SCC
5B
63BAHNSENAngelikaxxxxxxxxxGruppe A10:30
74BAHNSENUwexxxxxxxxxGruppe A10:30
85BARTELLenapermanent08:00-18:00SCC
96BARTELSJanpermanent08:00-18:00SCC
107BART-SCHLOTTHAUBERHeidrunxxxxxxxxxGruppe B12:00Travel Contact
Gesamt


Thanks in advance!
 

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).
Hi. I cannot test in 2003 but the problem is with the code for sorting which was changed in 2007. Here is the syntax for sorting in 2003

Code:
    .Range(.Cells(2, 1), Cells(LastRow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
 
Upvote 0
Thanks Vog -so this should work?

Code:
With ThisWorkbook.Sheets("Gesamt")
    
    .Range(.Cells(1, 2), .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 7)).Sort.Key1:=.Cells(2, 2), Order1:=xlAscending,Key2:=.Cells(2, 3), Order2:=xlAscending, Header:=xlno
        
End With
 
Upvote 0
Thank you. I'll give it to her and we'll see what happens. Why did they have to change that? :mad2: I mean, its not like its some obscure way of doing things which won't hurt anyone if they change it.

On a related note - is there any way to check for the XL version and invoke either the one or the other command? In my copy of XL 07 it doesn't seem to want to even compile the 2003 code - what about downward compability here?
 
Upvote 0
The code should compile in 2007. The code that I posted does.

I think that they changed the sort engine in 2007 but the 2003 syntax still works.
 
Upvote 0
hm, it doesnt.

Throws out the error message Compilation Error: expression expected (or something like that - it talks german to me) with the red part higlighted:

.range(...).sort Key1:=.cells(...)

edit: Forget it, discovered an extranous . after .range(...).sort , it compiles now.
 
Last edited:
Upvote 0

Forum statistics

Threads
1,224,502
Messages
6,179,126
Members
452,890
Latest member
Nikhil Ramesh

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