automatisch tabbladen aanmaken van Top 10 Namen

Status
Niet open voor verdere reacties.
I

Ijskegel

Gebruiker
Lid geworden
25 nov 2013
Berichten
19
Goedemiddag,

Ik heb een lijst van een paar honderduizend regels, in deze lijst staan in kolom "M", 14 tot 20 verschillende plaatsnamen.

Nu ben ik op zoek naar een stukje vba om een macro te maken die per plaatsnaam een nieuwe map maakt,
met daarin de data van de des betreffende plaatsnaam.


alvast hartelijk dank
Har
 

Bijlagen

  • Helpmij.xlsx
    14,5 KB · Weergaven: 40
Al zou ik alles in 1 tabel laten staan en met een filter of draaitabel de informatie opvragen. Zoiets?

Code: 
Sub VenA()
  With Sheets("Sheet1").Cells(1).CurrentRegion
    .Parent.Cells(1, 27) = "Startclock Service Center"
    ar = .Value
    Set d = CreateObject("Scripting.Dictionary")
      For j = 2 To UBound(ar)
        d.Item(ar(j, 13)) = ""
      Next j
      For Each it In d
        If IsError(Evaluate("'" & it & "'!A1")) Then Sheets.Add(, Sheets(Sheets.Count)).Name = it
        .Parent.Cells(2, 27) = it
        .AdvancedFilter xlFilterCopy, .Parent.Cells(1, 27).Resize(2), Sheets(it).Cells(1)
        With Sheets(it)
          .Rows.RowHeight = 12.75
          .Columns.AutoFit
        End With
      Next
      .Parent.Cells(1, 27).Resize(2).ClearContents
  End With
End Sub
 
VenA Geweldig dit is precies wat ik nodig heb

VenA zei:
Al zou ik alles in 1 tabel laten staan en met een filter of draaitabel de informatie opvragen. Zoiets?

Code: 
Sub VenA()
  With Sheets("Sheet1").Cells(1).CurrentRegion
    .Parent.Cells(1, 27) = "Startclock Service Center"
    ar = .Value
    Set d = CreateObject("Scripting.Dictionary")
      For j = 2 To UBound(ar)
        d.Item(ar(j, 13)) = ""
      Next j
      For Each it In d
        If IsError(Evaluate("'" & it & "'!A1")) Then Sheets.Add(, Sheets(Sheets.Count)).Name = it
        .Parent.Cells(2, 27) = it
        .AdvancedFilter xlFilterCopy, .Parent.Cells(1, 27).Resize(2), Sheets(it).Cells(1)
        With Sheets(it)
          .Rows.RowHeight = 12.75
          .Columns.AutoFit
        End With
      Next
      .Parent.Cells(1, 27).Resize(2).ClearContents
  End With
End Sub
Klik om te vergroten...
 
Het quoten is niet nodig.

Waarschijnlijk sneller bij veel rijen en korter.
Code: 
Sub VenA()
  With Sheets("Sheet1")
    .Columns(13).AdvancedFilter xlFilterCopy, , .Cells(1, 27), True
    ar = .Cells(1, 27).CurrentRegion
    For j = 2 To UBound(ar)
      .Cells(2, 27) = ar(j, 1)
      If IsError(Evaluate("'" & ar(j, 1) & "'!A1")) Then Sheets.Add(, Sheets(Sheets.Count)).Name = ar(j, 1)
      .Cells(1).CurrentRegion.AdvancedFilter xlFilterCopy, .Cells(1, 27).Resize(2), Sheets(ar(j, 1)).Cells(1)
      With Sheets(ar(j, 1))
        .Rows.RowHeight = 12.75
        .Columns.AutoFit
      End With
    Next j
    .Cells(1, 27).CurrentRegion.Clear
  End With
End Sub
 
Laatst bewerkt:
Dit lijkt mij handiger, omdat je daarna alleen nog maar hoeft te 'refreshen' om nieuwe gegevens per lokatie uitgesplitst te krijgen.

Code: 
Sub M_snb()
   Sheet1.Columns(13).AdvancedFilter 2, , Sheet1.Cells(1, 30), -1
   sn = Sheet1.Cells(1, 30).CurrentRegion
   Sheet1.Cells(1, 30).CurrentRegion.ClearContents
   
   For j = 2 To UBound(sn)
     With Sheets.Add(, Sheets(Sheets.Count))
       .Name = sn(j, 1)
       With .QueryTables.Add("ODBC;DSN=Excel-bestanden;DBQ=" & ThisWorkbook.FullName, .Cells(1))
         .CommandText = "SELECT * FROM `Sheet1$` WHERE `Startclock Service Center`='" & sn(j, 1) & "'"
         .Refresh 0
       End With
     End With
   Next
End Sub
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan