Sub Formattering()
Dim ws As Worksheet
Dim cell As Range
Dim rng As Range
Dim i As Long, lastrow As Long
Dim newname As String
Application.ScreenUpdating = False
newname = "Data"
On Error Resume Next
' Rename the first sheet to "Data"
ThisWorkbook.Sheets(1).Name = newname
On Error GoTo 0
' Unmerge cells in the first 10 rows in columns A to G
Set ws = ThisWorkbook.Sheets(newname)
For i = 1 To 10
Set rng = ws.Range("A" & i & ":G" & i)
If rng.MergeCells Then rng.UnMerge
Next i
' Set all cells to normal style
ws.Cells.Style = "Normal"
' Clear specific ranges
ws.Range("G4:BF4, F3:N3, H3:K4").ClearContents
' Insert columns with formatting
ws.Columns("D:E").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
' Determine the last row in column F
If ws.Range("F5").Value <> "" Then
lastrow = ws.Range("F5").End(xlDown).Row
Else
lastrow = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row
End If
' Create left and right sections in columns D and E
With ws.Range("D5:D" & lastrow)
.FormulaR1C1 = "=LEFT(RC[2], 3)"
.Value = .Value ' Convert to values
End With
ws.Range("E5:E" & lastrow).Value = ws.Range("D5:D" & lastrow).Value
' Insert title in cell B4
ws.Range("B4").Value = "Profit X"
' Sum columns M and N into column Q
With ws
.Range("Q1:Q" & lastrow).FormulaR1C1 = "=RC[-4] + RC[-3]"
.Range("Q1:Q" & lastrow).Value = .Range("Q1:Q" & lastrow).Value ' Convert
to values
End With
' Create a table from the data
With ws
Set tblrange = .Range("A4:Q" & lastrow)
On Error Resume Next
.ListObjects.Add(xlSrcRange, tblrange, , xlYes).Name = "Tabel_1"
On Error GoTo 0
tblrange.WrapText = False
.Columns("A:Q").AutoFit
End With
' Format numeric cells in column I
Set rng = ws.Range("I3:I" & ws.Cells(ws.Rows.Count, "I").End(xlUp).Row)
For Each cell In rng
If IsNumeric(cell.Value) And Not IsEmpty(cell.Value) Then
cell.Value = CLng(cell.Value)
cell.NumberFormat = "0"
End If
Next cell
' Replace "K T" with "KT" in column D and "K " with "KT" in column E
ws.Columns("D:E").Replace What:="K T", Replacement:="KT", LookAt:=xlPart
ws.Columns("D:E").Replace What:="K ", Replacement:="KT", LookAt:=xlPart
' Set timestamp
ThisWorkbook.Worksheets("Beregninger").Range("C2").Value = Format(Now, "dd-mm-
yyyy hh:mm:ss")
ws.Range("Q4").Value = "Faktisk ForbrugForpligtelser"
Application.ScreenUpdating = True
MsgBox "Data nu opdateret!"
End Sub
