Need someone with XL2003 to check some code please

[yytsunamiyy]

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
	A	B	C	D	E	F	G
1	Gsteliste SEA CLOUD, Mittwoch 04.05., Hamburg				Gruppe A
2
3	Dehlbrck
4
5	Lfd. Nr.	Name	Vorname	Personalausweis	Gruppe	Besucherzeit	Kontakt
6	1	SCHLICHT	Petra	xxxxxxxxxxx	Gruppe A	10:30	Dehlbrck
7	2	BAHNSEN	Uwe	xxxxxxxxxxx	Gruppe A	10:30	Dehlbrck
8	3	BAHNSEN	Angelika	xxxxxxxxxxx	Gruppe A	10:30	Dehlbrck
9	4	CLAUS	Manfred	xxxxxxxxxxx	Gruppe A	10:30	Dehlbrck
10	5	SCHMOLL-CLAUS	Elona	xxxxxxxxxxx	Gruppe A	10:30	Dehlbrck
11	6	KERN	Karl	xxxxxxxxxxx	Gruppe A	10:30	Dehlbrck
12	7	BEYER	Michaela		Gruppe A	10:30	Dehlbrck
Gruppe A

The 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
	A	B	C	D	E	F	G
1	Lfd. Nr.	Name	Vorname	Personalausweis	Gruppe	Besucherzeit	Kontakt
2		A
3	1	AMMERMANN	Silke		permanent	08:00-18:00	SCC
4	2	ASMUSSEN	Soeren		permanent	08:00-18:00	SCC
5		B
6	3	BAHNSEN	Angelika	xxxxxxxxx	Gruppe A	10:30
7	4	BAHNSEN	Uwe	xxxxxxxxx	Gruppe A	10:30
8	5	BARTEL	Lena		permanent	08:00-18:00	SCC
9	6	BARTELS	Jan		permanent	08:00-18:00	SCC
10	7	BART-SCHLOTTHAUBER	Heidrun	xxxxxxxxx	Gruppe B	12:00	Travel Contact
Gesamt

Thanks in advance!

 

[VoG]

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

    .Range(.Cells(2, 1), Cells(LastRow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

 

[yytsunamiyy]

Thanks Vog -so this should work?

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

 

[VoG]

Yes, that should work.

 

[yytsunamiyy]

Thank you. I'll give it to her and we'll see what happens. Why did they have to change that? 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?

 

[VoG]

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.

 

[yytsunamiyy]

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.