Automatisk oprettelse af faneblade med indhold

Hej Experter

Jeg har fundet denne rigtig gode kode i et tidligere spørgsmål herind omkring gadenavne.

Når jeg kører makroen kan jeg fint få oprettet fanebladene men får ikke de rækker med over, som er hæftet til selve oplysningen.

For at fortsætte i samme terminologi som det oprindelige spørgsmål blev oprettet i, er min problemstilling som følger.

a) Har en liste med gadenavne som står i kolonne A, hvor jeg ønsker der skal oprettes et faneblad pr. gadenavn - dette lykkes fint

b) Have overskriftslinjen med fra det oprindelige regneark med på hvert nye faneblad

c) Kopiere alle rækker som har det samme gadenavn i kolonne A over til det respektive nye faneblad

Jeg er stadig ny i VBA, og ved ikke om dette kan lade sig gøre med nedenstående kode?




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