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!
 

Some videos you may like

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying

VoG

Legend
Joined
Jun 19, 2002
Messages
63,650
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
 

yytsunamiyy

Well-known Member
Joined
Mar 17, 2008
Messages
963
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
 

yytsunamiyy

Well-known Member
Joined
Mar 17, 2008
Messages
963

ADVERTISEMENT

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

Legend
Joined
Jun 19, 2002
Messages
63,650
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

Well-known Member
Joined
Mar 17, 2008
Messages
963
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:

Watch MrExcel Video

Forum statistics

Threads
1,108,614
Messages
5,523,906
Members
409,542
Latest member
Shezz01

This Week's Hot Topics

Top