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:
The code:
The output:
Thanks in advance!
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:
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!