Opret ark og kopier data over afhængig af værdi i celle

Hej Sara

Det er ikke ønsketænkning - skulle nok kunne lade sig gøre.
Kunne du uploade filen eller en model heraf.

Hvad med den fremtidige ajourføring?

Det lyder rigtig godt - jeg kan godt sende dig en model af arket. Hvordan kan jeg vedhæfte det?

Ajourføring - det skal gerne være sådan at hvis jeg laver tilføjelser (fx nye personer eller afdelinger), så kan jeg opdatere og så kommer de over i det rette ark (oprettes nyt ark).

Og så er planen, at jeg vil bruge koden til de forskellige ark, som kommer i løbet af året, hvor jeg efterfølgende skal dele det ud i ark pr. afdeling.

Tak at du vil hjælpe!

Det er bestemt ikke ønsketænkning. Min første tanke er dog at du ikke nødvendigvis behøver en makro - faktisk kan du blot bruge pivot. Hvis du laver en pivot af din data med afdeling som filter - så kan man bede om at hver filter-mulighed. På dansk hedder den rapportfiltersider og ligger under indstillinger.

#2
Ok - gå ind på www.supertekst-it.dk | Kontakt - så sender jeg en mail til dig, som du kan anvende.

Det er lige gået op for mig, at jeg har skrevet forkert. Det jeg har brug for, er at den kan lave en ny fil pr. afdeling, ikke ark. Jeg har brug for at kunne gemme hver afdeling for sig. Kan det stadig lade sig gøre?

VBA-koden:
Rem Version 1 - 12.10.1016
Rem ======================
Dim oversigt As Object

Dim ræk As Integer, antalRækker As Integer
Dim afdnr As Integer, fraRæk As Integer, tilRæk As Integer
Dim overskrift
Public Sub fordelPrAfdeling()
    Set oversigt = ActiveWorkbook
    Set overskrift = Range("A1:AI1")
   
    antalRækker = Cells(Rows.Count, "A").End(xlUp).Row
   
    afdnr = Range("A" & 2)
    fraRæk = 2

    For ræk = 3 To antalRækker
        If Range("A" & ræk) <> afdnr Then
            tilRæk = ræk - 1
            opretAfdeling fraRæk, tilRæk, afdnr
            fraRæk = ræk
            afdnr = Range("A" & ræk)
Rem juster fra & til
        End If
    Next ræk
Rem opdater sidste afd
    tilRæk = ræk - 1
   
    For ræk = fraRæk To tilRæk
        opretAfdeling fraRæk, tilRæk, afdnr
        Exit For
    Next ræk
   
    MsgBox "Fordeling af afdelinger er udført"
End Sub
Private Sub opretAfdeling(fraRæk, tilRæk, afdnr)
Dim nyWBnavn As String
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
Rem Overskrift
    Range("A1:AI1").Select
    Selection.Copy
    Workbooks.Add
    nyWBnavn = ActiveWorkbook.Name
   
    ActiveWorkbook.ActiveSheet.Paste
    ActiveSheet.Cells.Select
    Cells.EntireColumn.AutoFit
   
Rem  Windows("Samlet afdelingsoversigt - ny.xlsx").Activate
    oversigt.Activate
    Application.CutCopyMode = False
   
Rem Afd. rækker
    Rows(fraRæk & ":" & tilRæk).Select
    Application.CutCopyMode = False
    Range("A" & fraRæk & ":AI" & tilRæk).Select
   
    Selection.Copy
    Windows(nyWBnavn).Activate
    ActiveWorkbook.Sheets(1).Range("A2").Select
    ActiveSheet.Paste
    ActiveSheet.Cells.Select
    ActiveSheet.Cells.EntireColumn.AutoFit
    Application.CutCopyMode = False

Rem Gem afd.filen
    ChDir "C:\Users\peter\Desktop\Eksperten\Sara_1013131"
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Users\peter\Desktop\Eksperten\Sara_1013131\Afd_" & afdnr & ".xlsx", FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
End Sub