Automatische aanmaak van tabbladen met de nodige info erin

[Leske]

Hallo,

Ik ben opzoek naar een macrootje waarbij hij gegevens van 1 tabblad gaat ,bij voorkeur, kopiëren naar een andere tabbad.
Hierbij moet hij zich baseren op een kolom.



De bedoeling is dat hij een tabblad aanmaakt per parking facility in de kolom parking facility met natuurlijk de benaming parking facility. Tevens als er gegevens instaan die betrekking dan hebben op die welbepaalde parking moet hij de volledige rij ook copierer naar dit tabblad.

Nu mijn kennis in Macro is beperkt. had een macro ervoor gemaakt. Maar deze loopt steeds vast en neemt zo'n 10 minuten in beslag. :s

De makro die ik heb is heel complex omgemaakt wat waarschijnlijk het probleem is.
Ik laat hem een filter zetten en dan zeg ik als hij B1000(vb van parking facility) vind moet hij een nieuwe sheet aanmaken deze dan B1000 noemen. Dan zeg ik dat hij van Rij 1 alles moet nemen tot de laatste rij.

Dit deed ik dan voor al de parkings wat vrij zwaar wordt als het om veel gegevens gaat.

Ben ervan overtuigd dat er een veel gemakkelijkere code voor moet bestaan.
Probleem is ben de taal niet machtig


Zou mijn macro er bij kunnen steken

Sub _uitsplitsing()
'
'uitsplitsing Macro
'
' Sneltoets: CTRL+SHIFT+T
'
Cells.Select
Cells.EntireColumn.AutoFit
Sheets("Blad1").Select
Sheets("Blad1").Name = "All"
Sheets("Blad2").Select
Sheets("Blad2").Name = "Overview"
Sheets("Blad3").Select
Sheets("Blad3").Name = "B1000"
Sheets.Add After:=Sheets(Sheets.Count)
Sheets("Blad4").Name = "B1010"

Sheets.Add After:=Sheets(Sheets.Count)
Sheets("Blad5").Name = "B1020"
Sheets.Add After:=Sheets(Sheets.Count)
Sheets("Blad6").Name = "B1030"
Sheets.Add After:=Sheets(Sheets.Count)
Sheets("Blad7").Name = "B1040"
Sheets.Add After:=Sheets(Sheets.Count)
Sheets("Blad8").Name = "B1080"
Sheets.Add After:=Sheets(Sheets.Count)
Sheets("Blad9").Name = "B1090"
Sheets.Add After:=Sheets(Sheets.Count)
Sheets("Blad10").Name = "B1100"
Sheets.Add After:=Sheets(Sheets.Count)
Sheets("Blad11").Name = "B1110"
Sheets.Add After:=Sheets(Sheets.Count)
Sheets("Blad12").Name = "B1120"
Sheets.Add After:=Sheets(Sheets.Count)
Sheets("Blad13").Name = "B1130"
Sheets.Add After:=Sheets(Sheets.Count)
Sheets("Blad14").Name = "B9999"

Sheets("Overview").Select
Sheets("Overview").Move Before:=Sheets(1)
Sheets("All").Select
Range("A1").Select
Selection.AutoFilter
Selection.AutoFilter Field:=7, Criteria1:="B1000"
Rows("1:1").Select
Range(Selection.Offset(0, 0), Selection.End(xlDown)).Select
Selection.Copy
ActiveWindow.ScrollWorkbookTabs Sheets:=1
Sheets("B1000").Select
ActiveSheet.Paste


Sheets("All").Select
Range("A1").Select
Selection.AutoFilter Field:=7, Criteria1:="B1010"
Rows("1:1").Select
Range(Selection.Offset(0, 0), Selection.End(xlDown)).Select
Selection.Copy
ActiveWindow.ScrollWorkbookTabs Sheets:=1
Sheets("B1010").Select
ActiveSheet.Paste

Sheets("All").Select
Range("A1").Select
Selection.AutoFilter Field:=7, Criteria1:="B1020"
Rows("1:1").Select
Range(Selection.Offset(0, 0), Selection.End(xlDown)).Select
Selection.Copy
ActiveWindow.ScrollWorkbookTabs Sheets:=1
Sheets("B1020").Select
ActiveSheet.Paste

Sheets("All").Select
Range("A1").Select
Selection.AutoFilter Field:=7, Criteria1:="B1030"
Rows("1:1").Select
Range(Selection.Offset(0, 0), Selection.End(xlDown)).Select
Selection.Copy
ActiveWindow.ScrollWorkbookTabs Sheets:=1
Sheets("B1030").Select
ActiveSheet.Paste

Sheets("All").Select
Range("A1").Select
Selection.AutoFilter Field:=7, Criteria1:="B1040"
Rows("1:1").Select
Range(Selection.Offset(0, 0), Selection.End(xlDown)).Select
Selection.Copy
ActiveWindow.ScrollWorkbookTabs Sheets:=1
Sheets("B1040").Select
ActiveSheet.Paste

Sheets("All").Select
Range("A1").Select
Selection.AutoFilter Field:=7, Criteria1:="B1080"
Rows("1:1").Select
Range(Selection.Offset(0, 0), Selection.End(xlDown)).Select
Selection.Copy
ActiveWindow.ScrollWorkbookTabs Sheets:=1
Sheets("B1080").Select
ActiveSheet.Paste

Sheets("All").Select
Range("A1").Select
Selection.AutoFilter Field:=7, Criteria1:="B1090"
Rows("1:1").Select
Range(Selection.Offset(0, 0), Selection.End(xlDown)).Select
Selection.Copy
ActiveWindow.ScrollWorkbookTabs Sheets:=1
Sheets("B1090").Select
ActiveSheet.Paste

Sheets("All").Select
Range("A1").Select
Selection.AutoFilter Field:=7, Criteria1:="B1100"
Rows("1:1").Select
Range(Selection.Offset(0, 0), Selection.End(xlDown)).Select
Selection.Copy
ActiveWindow.ScrollWorkbookTabs Sheets:=1
Sheets("B1100").Select
ActiveSheet.Paste

Sheets("All").Select
Range("A1").Select
Selection.AutoFilter Field:=7, Criteria1:="B1110"
Rows("1:1").Select
Range(Selection.Offset(0, 0), Selection.End(xlDown)).Select
Selection.Copy
ActiveWindow.ScrollWorkbookTabs Sheets:=1
Sheets("B1110").Select
ActiveSheet.Paste

Sheets("All").Select
Range("A1").Select
Selection.AutoFilter Field:=7, Criteria1:="B1120"
Rows("1:1").Select
Range(Selection.Offset(0, 0), Selection.End(xlDown)).Select
Selection.Copy
ActiveWindow.ScrollWorkbookTabs Sheets:=1
Sheets("B1120").Select
ActiveSheet.Paste


Sheets("All").Select
Range("A1").Select
Selection.AutoFilter Field:=7, Criteria1:="B1130"
Rows("1:1").Select
Range(Selection.Offset(0, 0), Selection.End(xlDown)).Select
Selection.Copy
ActiveWindow.ScrollWorkbookTabs Sheets:=1
Sheets("B1130").Select
ActiveSheet.Paste


Sheets("All").Select
Range("A1").Select
Selection.AutoFilter Field:=7, Criteria1:="B9999"
Rows("1:1").Select
Range(Selection.Offset(0, 0), Selection.End(xlDown)).Select
Selection.Copy
ActiveWindow.ScrollWorkbookTabs Sheets:=1
Sheets("B9999").Select
ActiveSheet.Paste


End Sub

Ik denk niet dat dit ideaal is vandaar


Wat ik als macro heb werkt gedeeltelijk ik zoek gewoon een vereenvoudiging ervan.

Eentje waar hij automatisch een tabblad aanmaakt per parking facility (en deze naar die parking facility benoemd) gebasseerd op de kolom van parking facility
en dat hij dan al de lijnen van dezelfde parking facility copieert naar de juiste tabblad.

mvg,


thx for the help

 

[Warme bakkertje]

Kan je misschien een voorbeeldbestandje plaatsen met wat gegevens erin zodat we iets hebben om mee te werken, dat spreekt makkelijker.

 

[Leske]

Bekijk bijlage Map5.xlsx

 

[Warme bakkertje]

Test deze eens

Sub uniek()
On Error Resume Next
With Sheets("Lijst")
    .AutoFilterMode = False
    sq = .Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row)
    For Each cl In sq
        If InStr(c01, cl) = 0 Then c01 = c01 & "|" & cl
    Next
Application.DisplayAlerts = False
Worksheets.Add().Name = "UniqueList"
[UniqueList!A1].Resize(UBound(Split(c01, "|"))) = Application.Transpose(Split(c01, "|"))
    For Each rCell In Sheets("UniqueList").Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
        strText = rCell
        .Range("B1").AutoFilter 2, strText
        Worksheets(strText).Delete
        Worksheets.Add().Name = strText
        .UsedRange.Copy Destination:=ActiveSheet.Range("A1")
        ActiveSheet.Cells.Columns.AutoFit
    Next rCell
    .AutoFilterMode = False
End With
Worksheets("UniqueList").Delete
Application.Goto [Lijst!A1]
Application.DisplayAlerts = True
End Sub