Per locatie pad een sheet maken , verplaatsen en opslaan

[HWV]

Beste,

Ik heb een lijst met locatie`s

1A022C
1B023A
2A023A
2B012C
3A012C
3B021A
4A021A
4B022C
5A022C
5B023A

Per straat (1a, 2b,3c enz) zijn het ongeveer 100 locatie`s
Nu heb ik het volgende om deze per sheet te plaatsen
Maar volgens mij kan het ook anders, nu moet ik per locatie een verwijzing maken, is er een locatie die ik overslaat dan gaat het niet goed.

Is het volgende mogelijk:

- Hij maak voor elke verschillende straat een sheet aan en dan kijken naar de eerste twee karakters van links
- kortere code zodat ik niet elke straat moet verwijzen zoals in mijn script hier beneden, zodat ik ik niks kan vergeten.
- nu wil ik ook dat ze per blad dan apart worden op geslagen op een locatie op mijn P schijf, met naam de eerste twee karakters

 Sheets("Data").Select
   Dim c As Range
   For Each c In [A1:A1000]
        If Left(c(1, "A"), 2) = "7A" Then
            c.Rows.EntireRow.Copy
            ['7A'!A65536].End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End If
    Next
    
    For Each c In [A1:A1000]
        If Left(c(1, "A"), 2) = "7B" Then
            c.Rows.EntireRow.Copy
            ['7B'!A65536].End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End If
    Next

Graag hoor ik of dit mogelijk is om deze stappen makkelijker te maken als dat ik ze nu heb.

Groet HWV

 

[HWV]

Opgelost !

Beste,

Het is mij gelukt met onderstaande code:

Kijk in kolom A, naar de eerste twee positie`s
deze verzameld hij op een aangemaakte sheet met de naam van de eerste twee positie`s
uiteindelijk per sheet een bewerking uitvoeren door aanroepen van twee andere macro`s
en opslaan per sheet

Sub Tellijsten_Maken()

On Error GoTo Err_Knop1_Click

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

Sheets("Data").Select

Dim c As Range
    Dim ws As Worksheet
    Dim ws1 As Worksheet
    Dim sh As Object
    
    On Error Resume Next
    
    Set ws1 = ThisWorkbook.Worksheets("Data")
    
    For Each c In ws1.Range("A2", ws1.Range("A" & Rows.Count).End(xlUp))
        
        
        If WksExists(Left(c(1, "A"), 2)) Then
        
            Set ws = ThisWorkbook.Worksheets(c.Text)
            
        Else
        
            Set ws = ThisWorkbook.Worksheets.Add
            ws.Name = Left(c(1, "A"), 2)
        
        End If
        
        c.Resize(, 26).Copy ws.Range("A" & Rows.Count).End(xlUp).Offset(1)
        
    Next

ws1.Select

    For Each sh In ThisWorkbook.Sheets
        If sh.Index > "" Then
                Sheets(sh.Name).Select
                
            KaderOpmaak 'aanroepen formule
            pagina_Instellingen 'aanroepen formule
            
        End If
    
    Next sh

    For Each ws In ThisWorkbook.Worksheets
           
        Sheets(ws.Name).Select
        Sheets(ws.Name).Copy
        ActiveWorkbook.SaveAs Filename:= _
        "P:\automatisering\tellijsten maken\Gereed export\" & ws.Name & ".xlsx", FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWorkbook.Close
        ThisWorkbook.Activate
    Next

With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
End With

Exit_Knop1_Click:
Exit Sub
Err_Knop1_Click:
MsgBox Err.Description
Resume Exit_Knop1_Click

End Sub

Groet HWV