Avatar billede SFrede Juniormester
07. oktober 2016 - 10:34 Der er 5 kommentarer og
1 løsning

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

Hej
Jeg har en tilbagevende opgave, som jeg tænker at VBA-kodning kan gøre lettere for mig. Jeg er dog stadig meget ny til det og kan ikke finde frem til hvordan det kan gøres, så jeg håber nogle kan hjælpe mig.

Jeg har et regneark (udfyldt kolonne A - AI), hvor en masse personer er listet (starter i række 2 pga. overskrifter) sorteret i hvilken afdeling de tilhører (Kolonne A).

Jeg har tit brug for at lave et ark for hver afdeling, hvor de fulde rækker for afdelingen er kopieret over.
Altså, skal jeg ende ud med et ark for fx: Økonomi, Administration, HR osv. hvor alt det der står i en række for en person i den afdeling, er kopieret med over.

Jeg kunne godt tænke mig, at ved et tryk på en knap, så opretter den et ark for hver afdeling, hvor de personer der er i afdelingen ligger i. Er det ønsketænkning?

Håber der er nogle der har tid og lyst til at hjælpe mig.

Mvh. Sara
Avatar billede supertekst Ekspert
07. oktober 2016 - 11:49 #1
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?
Avatar billede SFrede Juniormester
07. oktober 2016 - 12:55 #2
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!
Avatar billede kim1a Ekspert
07. oktober 2016 - 13:05 #3
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.
Avatar billede supertekst Ekspert
07. oktober 2016 - 13:11 #4
#2
Ok - gå ind på www.supertekst-it.dk | Kontakt - så sender jeg en mail til dig, som du kan anvende.
Avatar billede SFrede Juniormester
10. oktober 2016 - 09:32 #5
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?
Avatar billede supertekst Ekspert
13. oktober 2016 - 14:36 #6
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
Avatar billede Ny bruger Nybegynder

Din løsning...

Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.

Loading billede Opret Preview
Kategori
Vi har et stort udvalg af Excel kurser. Find lige det kursus der passer dig lige her.

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester