Option Explicit
Public Sub TurboExport()
'met de vriendelijke groeten van Mark
Const ZOEK_KOLOM As String = "K" 'Bepaalt de zoekkolom
Const LAATSTE_KOLOM As String = "L" 'de laaste kolom met data
Dim workbookCounter As Long 'houd bij hoeveel werkmappen zijn geexporteerd
[COLOR="red"]Dim exportHeaders As Range [/COLOR] 'de kolomkoppen
Dim exportBereik As Range 'het te exporteren bereik
Dim Begin As Range
Dim Einde As Range
Dim Locatie As String 'de naam van de locatie
'bereik sorteren zodat locaties onder elkaar komen
Range(ZOEK_KOLOM & "1").CurrentRegion.Sort Key1:=Range(ZOEK_KOLOM & "1"), _
Order1:=xlAscending, _
Header:=xlYes
'de zoekkolom is ZOEK_KOLOM
[COLOR="red"]Set exportHeaders = Range(ZOEK_KOLOM & "1").CurrentRegion.Resize(1)[/COLOR]
Set Begin = Range(ZOEK_KOLOM & "2")
Application.ScreenUpdating = False
On Error GoTo Abort:
Do While Begin <> vbNullString
Locatie = Begin.Value 'de naam van de locatie
workbookCounter = workbookCounter + 1 'want de naam is niet leeg
Application.StatusBar = "opslaan " & Locatie
'zoek de laatste cel met de locatie
Set Einde = VindLaatsteCel(Locatie, Columns(ZOEK_KOLOM), Begin)
'de te kopiëren data bepalen:
Set exportBereik = Range("A" & Begin.Row, LAATSTE_KOLOM & Einde.Row)
'sla de data op
MaakLocatieMap Locatie, exportBereik[COLOR="red"], exportHeaders[/COLOR]
'de volgende locatie
Set Begin = Einde.Offset(1)
Loop
Abort:
'bij fouten instellingen herstellen en rommel opruimen
Application.ScreenUpdating = True
Application.StatusBar = Empty
If Err.Number <> 0 Then
MsgBox "Procedure afgebroken, " & vbNewLine & _
"De volgende fout is opgetreden:" & vbNewLine & _
Err.Description
Else
MsgBox "Klaar! " & workbookCounter & " bestand(en) aangemaakt."
End If
Set exportBereik = Nothing
[COLOR="red"]Set exportHeaders = Nothing[/COLOR]
Set Begin = Nothing
Set Einde = Nothing
End Sub
Private Function VindLaatsteCel(ByVal zoekwaarde As String, _
ByVal ZoekBereik As Range, _
Optional ByVal Begin As Range) As Range
'werkt alleen goed op gesorteerd bereik
Set VindLaatsteCel = ZoekBereik.Find(What:=zoekwaarde, _
After:=Begin, _
LookIn:=xlValues, _
lookat:=xlWhole, _
MatchCase:=False, _
SearchDirection:=xlPrevious)
End Function
Private Sub MaakLocatieMap(ByVal naam As String, _
ByVal data As Range, _
[COLOR="red"]ByVal headers As Range[/COLOR])
'sla bestand op de de gewenste map.
Const SAVE_PATH As String = "C:\Temp\" 'vul hier de naam van de map in
'vergeet de backslash aan het einde niet
Dim bestand As Excel.Workbook 'het workbook object dat opgeslagen wordt
Dim bestandsnaam As String 'de bestandsnaam voor het opslaan
Set bestand = Workbooks.Add()
'kopieer de data naar de nieuwe werkmap
[COLOR="red"]headers.Copy Destination:=bestand.Sheets(1).Range("a1")[/COLOR]
data.Copy Destination:=bestand.Sheets(1).Range("a2")
bestandsnaam = "C:\temp\" & naam
bestand.SaveAs bestandsnaam
bestand.Close False
'bestandvariabele opruimen
Set bestand = Nothing
End Sub
de locaties staan in kolom "K"?
