EXCEL: Opdel og gem

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.

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

i samme fil? - mener du ikke samme Ark??

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

Har du testet det???

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!!

Ja - vender tilbage hertil..

Og en sidste ting :D

Kan den enten bevare kolonne bredden fra det originale dokument eller automatisk tilpasse dem bredden på indholdet!

Ja - alt kan jo (næsten) lade sig gøre...

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! :-)

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

LUKKETID?