Automatisk oprettelse af faneblade

Denne kode opretter et ark for hver af cellerne A1:FS1 (175) i alt og navngiver de enkelte ark, efter indholdet af cellerne. Ret selv til det rigtige område.

Sub arknavne()
    For Each c In ActiveSheet.Range("a1:fs1").Cells
        Sheets.Add
        ActiveSheet.Name = c.Value
    Next c
End Sub

sæt denne kode ind i et alm. makromodul.
Stil dig på arket med de 10000 linier og kør makroen
Du bliver så bedt om at angive start af dataområde.
hvis dine dataoverskrifter starter i A1, så udpeg celle A1
Dernæst blive du bedt om Indexkolonne. Her udpeger du 1. celle i kolonnen med gadenavnene.
Makroen opretter nu et ark for hvert gadenavn den finder i indexkolonnen og kopierer alle fra samme gade over i dette ark.
Gør det nu endelig fra en kopi af din fil :-)



Option Base 1
Option Explicit

Sub Filter_Distribute()
    'by Tommy Christensen
    '*** Dim vars
    Dim iX As Long
    Dim Uniq_Matrix As New Collection
    Dim TempMatrix
    Dim varItem
    Dim wshStart As Worksheet
    Dim rngStart As Range
    Dim rngIndex As Range
    Dim lngFilterCol As Long
    Dim lngCnt1 As Long
    Dim lngCnt2 As Long
   
    '*** Initializing sequence
    Set wshStart = ActiveSheet
    With Application
        Set rngStart = .InputBox("Startcelle af dataområde", Type:=8)
        Set rngIndex = .InputBox("Index-kolonne (Gadenavnskolonne) ", Type:=8)
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
   
    '*** Fill all data of Index-Column into an array
    With rngIndex
        TempMatrix = Range(Cells(.Row, .Column), Cells(65536, .Column).End(xlUp).Address)
        lngFilterCol = .Column - rngStart.Column + 1
    End With
   
    '*** Fill Uniq_Matrix with Unique values
    On Error Resume Next
    For iX = 2 To UBound(TempMatrix)
        Uniq_Matrix.Add TempMatrix(iX, 1), CStr(TempMatrix(iX, 1))
    Next iX
    On Error GoTo cleanup
   
    '*** Dismis TempMatrix to regain memory
    Set TempMatrix = Nothing
    lngCnt1 = Uniq_Matrix.Count
   
    '*** Make new sheets or clear contents of old sheets
    For Each varItem In Uniq_Matrix
      If SheetExists(ActiveWorkbook.Worksheets, CStr(varItem)) Then
          'Sheets(CStr(varItem)).Range("A1").CurrentRegion.ClearContents
          Else
          Sheets.Add
          ActiveSheet.Name = varItem
      End If
    Next
   
    '*** Set autofilter on all unique item and
    '*** copy the result to corresponding sheet
    For Each varItem In Uniq_Matrix
        With rngStart.Cells(1, 1)
            .AutoFilter Field:=lngFilterCol, Criteria1:=varItem
            .CurrentRegion.Copy
        End With
        Sheets(varItem).Range("A1").PasteSpecial (xlPasteValues)
        lngCnt2 = lngCnt2 + 1
        Application.StatusBar = lngCnt2 & " af " & lngCnt1
    Next

cleanup:
  '***  Cleanup and finish the job
    rngStart.AutoFilter
    With Application
      .StatusBar = False
      .CutCopyMode = False
      .Calculation = xlCalculationAutomatic
      .ScreenUpdating = True
    End With
    Set Uniq_Matrix = Nothing
End Sub

Function SheetExists(Coln As Object, Item As String) As Boolean
  Dim Obj As Object
  On Error Resume Next
  Set Obj = Coln(Item)
  SheetExists = Not Obj Is Nothing
End Function

.......nå ja. du skrev jo kun at du ønskede at oprette arkene, ikke at du ville kopiere data over i dem :-)

I det tilfælde skal du bruge jkrons's kode ........

For at lave arkene automatisk uden vba, skal du lave en pivottabel på arket med 10000 linier
Så sætter du feltet med gadenavnene op som sidefelt
Højreklik så på feltet og vælg "Vis Sider"
Excel genererer nu alle 175 ark med en pivottabel i hver.
Marker alle disse ark (faneblade) på en gang , marker så hele det aktive ark ved at trykke på firkanter øverst i venstre hjørne (ved siden af kolonne A og lige over række 1.
Vælg så "Rediger, Ryd, Alt"
du har så 175 tomme ark.

Tak for de hurtige svar - kan se, at det kan kan gøres uden vba, hvilket jeg i først omgang vil foretrække. Men . . .

bak: Jeg kan ikke få det til at virke ud fra din beskrivelse - her er hvad jeg gør:
1) Marker området med de 10000 linier
2) "data" - "pivot tabel" . . .
3) layout - trækker gade over på "side", og anden info ind i "data området"
4) Udfør

Jeg kan ikke lave "vis sider" - kan du beskrive det lidt nærmere, for jeg må lave noget andet end du foreslår.

Har MS office 2003.

i excel 2003 ligger denne option ikke lige for...
Stil dig på sidefeltet.
Så findes muligheden på værktøjslinien "Pivottabel"  under rullefeltet Pivottabel nederst.

Damm - hvor enkelt og smart. Lykkedes uden vba.

Tak for svaret - rent praktisk, hvordan sender jeg points til rette mand her? bak vil få point da det i størst omfang rammer mit mål (tak for input alligevel jkrons).

Jeg skal lige give et svar, før du kan gi' point.
Her er det så...

Tak for hjælpen.