Gegevens van 3 werkbladen samenvoegen op 1 nieuw werkblad

[Guus]

Hallo,
Ik heb een Excelbestand met adressen.
De afzonderlijke werkbladen betreffen bepaalde werkgroepen.

In de kolommen A t/m D staan de volgende gegevens:
Naam, Adres, Woonplaats, Telefoon

Nu wil ik graag een nieuw werkblad TOTAAL maken, dat alle namen bevat van de
afzonderlijke werkbladen.

Wie kan mij aan een stukje VBA-helpen voor een macro?
Alvast bedankt,
Guus

[Ron de Bruin]

Probeer dit eens
http://www.rondebruin.nl/copy2.htm

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

"Guus" <Gu...@discussions.microsoft.com> wrote in message news:221565C0-047E-4D5B...@microsoft.com...

[Guus]

Ron bedankt voor jouw hulp !

De oplossing is:
Sub SamenvoegenWerkbladen()
'
' Macro SamenvoegenWerkbladen
' Macro recorded 22-01-2008
'
Dim Groep As Worksheet
Dim Doel As Worksheet
Dim Last As Long

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Delete the sheet "Totaal Overzicht" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Totaal Overzicht").Delete
On Error GoTo 0
Application.DisplayAlerts = True

'Add a worksheet with the name "Totaal Overzicht"
Set Doel = Worksheets.Add
Doel.Name = "Totaal Overzicht"
'Nieuw = ActiveWindow.WindowNumber

'Loop through all worksheets and copy the data to the Doel
For Each Groep In ActiveWorkbook.Worksheets

'Ga naar de laatste cel
ActiveCell.SpecialCells(xlLastCell).Select
Last = ActiveCell.Row

If Groep.Name <> Doel.Name And _
Groep.Name <> "Blad 1" And _
Groep.Name <> "Blad 2" And _
Groep.Name <> "Blad 3" Then

Last = LastRow(Doel)

'This example copies everything
Groep.Range("A2:AX100").Copy Doel.Cells(Last + 1, "A")

'This will copy the sheet name in the A column
'Doel.Cells(Last + 1, "A").Value = Groep.Name

End If
Next
Doel.Range("A1").Select
Selection.EntireRow.Insert

'Kopregel kopiëren
Worksheets("Blad1").Select
Range("A1").Select
Rows("1:1").Select
Selection.Copy Doel.Cells(1, "A")

Doel.Activate
Cells.Select
Cells.EntireColumn.AutoFit
Range("A1").Select

Columns("C:C").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False

Columns("A:B").Select
Selection.Delete Shift:=xlToLeft
Range("A2").Select

With Application
.ScreenUpdating = True
.EnableEvents = True
End With

'Lege Regels Verwijderen
While ActiveCell.Row < 141
'Als de huidige cel leeg is
If ActiveCell = Empty Then
Selection.EntireRow.Delete
Else
'Ga vanaf helemaal links
Selection.End(xlToLeft).Select
'Eén regel omlaag
ActiveCell.Offset(1, 0).Select
End If
Wend
Range("A2").Select

With Application
.ScreenUpdating = True
.EnableEvents = True
End With

End Sub

Groet,
Guus