Avatar billede wever Nybegynder
23. april 2010 - 17:44 Der er 11 kommentarer og
1 løsning

EXCEL: Opdel og gem

Hej

Jeg vil gerne have splittet en Excel fil op og gemt med forskellige navne.

Jeg har et langt ark som jeg gerne vil have spillet op på følgende måde:

1) En standard del: To rækker, der indeholder kolonne etiketter.

2) En variabel del:
For hver forskellig værdi der er i kolonne E, samler den alle dem der er ens, og gemmer dem i det ark hvor standard delen også er.

EKS:

Navn | Højde | Rand
HrAA | 100  | 23
HrBB | 100  | 53
HrCC | 200  | 44

Bliver til

Navn | Højde | Rand
HrAA | 100  | 23
HrBB | 100  | 53

OG:

Navn | Højde | Rand
HrCC | 200  | 44

__
Jeg har mulighed for at få det over i en Pivot tabel, hvis det forenkler processen.
Avatar billede supertekst Ekspert
24. april 2010 - 13:41 #1
Vil det sige, at man kunne navngive de enkelte ark med indholdet i kolonne E?

Det skulle ikke være noget problem via VBA.

Har du en model/udsnit af filen - så er du velkommen til at sende den. @-adr. under min profil.
Avatar billede wever Nybegynder
25. april 2010 - 13:02 #2
Ja:
Alle personer som har højden 100 kommer i samme fil som hedder højde_100 og alle med højden 200 kommer i højde_200
Avatar billede supertekst Ekspert
25. april 2010 - 18:02 #3
i samme fil? - mener du ikke samme Ark??
Avatar billede supertekst Ekspert
26. april 2010 - 10:26 #4
VBA-koden anbringes under arket med alle data (juster evt. navn)
Slet øvrige evt. ark - Alt+F8 - afspil makroen "opdelingAfHøjde"
================================================================

Dim arkData As Object
Public Sub opdelingAfHøjde()
Const arkMedAlleData = "Alle"    '<<<<<< <---- justeres

Dim sidsterække As Long, sidsteKolonne As Byte
Dim ræk As Long, højde As Integer, antalArk As Byte

    Application.ScreenUpdating = False
   
    Set arkData = ActiveWorkbook.Sheets(arkMedAlleData)
   
Rem beregn dimensioner
    sidsterække = ActiveCell.SpecialCells(xlLastCell).Row
    sidsteKolonne = ActiveCell.SpecialCells(xlLastCell).Column
   
Rem traverser arket "Alle"
    For ræk = 3 To sidsterække
        antalArk = ActiveWorkbook.Sheets.Count
        højde = Range("E" & CStr(ræk))
       
        If findesArket(højde) = False Then
Rem opret det nye ark
            ActiveWorkbook.Sheets.Add After:=Sheets(antalArk)
            ActiveSheet.Name = højde
            indsætOverskrift højde
        End If
       
        indsætData højde, ræk, findLedigRække(højde)
       
        arkData.Activate
    Next ræk
   
    Application.ScreenUpdating = True
    MsgBox ("Opdelingt er udført")
   
End Sub
Private Function findesArket(højde)
Dim ark As Object
    For Each ark In ActiveWorkbook.Sheets
        If CStr(højde) = ark.Name Then
            findesArket = True
            Exit Function
        End If
    Next
   
    findesArket = False
End Function
Private Sub indsætOverskrift(højde)
    arkData.Select
    Range("A1:IV2").Select
    Selection.Copy
         
    Sheets(CStr(højde)).Select
    ActiveSheet.Paste
       
    Application.CutCopyMode = False
End Sub
Private Sub indsætData(højde, fraRække, tilRække)
    arkData.Select
    Range("A" & CStr(fraRække) & ":IV" & CStr(fraRække)).Select
    Selection.Copy
         
    Sheets(CStr(højde)).Select
    ActiveSheet.Rows(tilRække).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
End Sub
Private Function findLedigRække(ark)
    ActiveWorkbook.Sheets(CStr(ark)).Select
    findLedigRække = ActiveCell.SpecialCells(xlLastCell).Row + 1
End Function
Avatar billede supertekst Ekspert
07. maj 2010 - 17:59 #5
Har du testet det???
Avatar billede wever Nybegynder
21. maj 2010 - 10:39 #6
Det virker fint, men kan det lade sig gøre at den opretter det i hver sin fil i stedet for forskellige ark?

Evt. gemmer dem automatisk!!
Avatar billede supertekst Ekspert
21. maj 2010 - 10:49 #7
Ja - vender tilbage hertil..
Avatar billede wever Nybegynder
21. maj 2010 - 10:55 #8
Og en sidste ting :D

Kan den enten bevare kolonne bredden fra det originale dokument eller automatisk tilpasse dem bredden på indholdet!
Avatar billede supertekst Ekspert
21. maj 2010 - 11:09 #9
Ja - alt kan jo (næsten) lade sig gøre...
Avatar billede wever Nybegynder
21. maj 2010 - 11:22 #10
Hehe, det er jo det.

Kunne se at den brugte standard bredden, tager lidt tid at rette når antallet af ark går der opad! :-)
Avatar billede supertekst Ekspert
27. maj 2010 - 11:10 #11
Rem VERSION 2
Rem =========
Const arkMedAlleData = "Alle"    '<<<<<< <---- justeres
Dim arkData As Object, sti As String
Public Sub opdelingAfHøjde()
Dim sidsterække As Long, sidsteKolonne As Byte
Dim ræk As Long, højde As Integer, antalArk As Byte

    Application.ScreenUpdating = False
   
Rem Sti, hvor de separate filer lagres
    sti = ActiveWorkbook.Path
    If Right(sti, 1) <> "\" Then
        sti = sti + "\"
    End If
   
    Set arkData = ActiveWorkbook.Sheets(arkMedAlleData)
   
Rem beregn dimensioner
    sidsterække = ActiveCell.SpecialCells(xlLastCell).Row
    sidsteKolonne = ActiveCell.SpecialCells(xlLastCell).Column
   
Rem traverser arket "Alle"
    For ræk = 3 To sidsterække
        antalArk = ActiveWorkbook.Sheets.Count
        højde = Range("E" & CStr(ræk))
       
        If findesArket(højde) = False Then
Rem opret det nye ark
            ActiveWorkbook.Sheets.Add After:=Sheets(antalArk)
            ActiveSheet.Name = højde
            indsætOverskrift højde
        End If
       
        indsætData højde, ræk, findLedigRække(højde)
       
        arkData.Activate
    Next ræk
   
    overførArkTilFil
   
    Application.ScreenUpdating = True

    MsgBox ("Opdeling er udført")
   
End Sub
Private Function findesArket(højde)
Dim ark As Object
    For Each ark In ActiveWorkbook.Sheets
        If CStr(højde) = ark.Name Then
            findesArket = True
            Exit Function
        End If
    Next
   
    findesArket = False
End Function
Private Sub indsætOverskrift(højde)
    arkData.Select
    Range("A1:IV2").Select
    Selection.Copy
         
    Sheets(CStr(højde)).Select
    ActiveSheet.Paste
       
    Application.CutCopyMode = False
End Sub
Private Sub indsætData(højde, fraRække, tilRække)
    arkData.Select
    Range("A" & CStr(fraRække) & ":IV" & CStr(fraRække)).Select
    Selection.Copy
         
    Sheets(CStr(højde)).Select
    ActiveSheet.Rows(tilRække).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
   
    Columns.AutoFit
End Sub
Private Function findLedigRække(ark)
    ActiveWorkbook.Sheets(CStr(ark)).Select
    findLedigRække = ActiveCell.SpecialCells(xlLastCell).Row + 1
End Function
Private Sub overførArkTilFil()
Dim ark, wbNavn As String
    For Each ark In ActiveWorkbook.Sheets
        If ark.Name <> arkMedAlleData Then
            ark.Select
            ark.Move
            wbNavn = ActiveSheet.Name & ".xls"
           
            ActiveWorkbook.SaveAs Filename:= _
                sti & wbNavn, FileFormat:= _
                xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
                , CreateBackup:=False
            ActiveWindow.Close
        End If
    Next ark
End Sub
Avatar billede supertekst Ekspert
14. juni 2010 - 13:46 #12
LUKKETID?
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
IT-kurser om Microsoft 365, sikkerhed, personlig vækst, udvikling, digital markedsføring, grafisk design, SAP og forretningsanalyse.

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