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