Automatisk oprettelse af faneblade med indhold
Hej ExperterJeg 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