Scribd
Upload
4 views

Code Cleaned

Uploaded by

mlbfcacygyxepimrfi
Copyright
© © All Rights Reserved
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
4 views

Code Cleaned

Uploaded by

mlbfcacygyxepimrfi
Copyright
© © All Rights Reserved
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
You are on page 1/ 2

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

You might also like