Reformat Excel Report

Target audience: Excel users
Used tools: Excel VBA
What’s the purpose: Change the view of Excel report file

This will be a post about using VBA macro in MS Excel report of evidence such as for receiving some materials in the store, using report, received from a software program. In other words – to reformat prepared report so, that it will fulfill our requirements how it has to look like.

At first, we have Excel file, for example dataReport.xlsx generated from some application as a kind of report. which looks like this :

And here is another Excel file – protocol.xlsm, with VBA macro in it :

And here is a final result when we execute macro :

And here is the VBA code :

Option Explicit

Sub GetDataFromClosedBook()

ThisWorkbook.Worksheets(1).Range("$B$6:$N$299").Clear

PrintColumns

Dim lstRcl As Long
lstRcl = LastRowFromClosedFile("D:\", "dataReport.xlsx", "Sheet1", "N6", 14)

Dim mydata As String
'data location & range to copy
mydata = "='D:\[dataReport.xlsx]Sheet1'!$B$6:$N$" & lstRcl 

With ThisWorkbook.Worksheets(1).Range("$B$6:$N$" & lstRcl)
.Formula = mydata
'convert formula to text
.Value = .Value
End With

With ThisWorkbook.Worksheets(1).Range("$K$3:$K$3")
 ' !!! EXACTLY in this way : "=" & "'" & "D:\ 
.Formula = "=" & "'" & "D:\[dataReport.xlsx]Sheet1'!$M$3:$M$3" 
'convert formula to text
.NumberFormat = "@"
.Value = .Value
End With

With ThisWorkbook.Worksheets(1).Range("$K$4:$K$4")

.Formula = "='D:\[dataReport.xlsx]Sheet1'!$R$3:$R$3"
'convert formula to text
.NumberFormat = "@"
.Value = .Value

End With

ActiveSheet.Columns("K:N").NumberFormat = "0.00"
ActiveSheet.Columns("D:N").EntireColumn.AutoFit

'Format Column A as text
ActiveSheet.Columns("B:B").NumberFormat = "@"

'Za da se vijda kato TEXT a ne kato scietific  format
Dim cell
For Each cell In ThisWorkbook.Worksheets(1).Range("$B$6:$B$" & lstRcl - 1)
    cell.Value = "'" & cell.Value
Next

ActiveSheet.Columns("B:C").EntireColumn.AutoFit
ActiveSheet.Columns("D:I").ColumnWidth = 2

Cells(2, 11).NumberFormat = "dd/mm/yyyy"

' Get the worksheet
'Dim shRead As Worksheet
'Set shRead = ThisWorkbook.Worksheets("Sheet1")

'Clear cells with ZEROs !!!
ThisWorkbook.Worksheets("Sheet1").Range("D6:J" & lstRcl).Clear
ThisWorkbook.Worksheets("Sheet1").Range("M6:M" & lstRcl).Clear
'Clear range in lstRtl between columns B and N
ThisWorkbook.Worksheets("Sheet1").Range(Cells(lstRcl, 2), Cells(lstRcl, 14)).Clear

'Draw Grid Lines in range
Dim strRng As String
strRng = "$B$6:$N$" & lstRcl - 1
DrawGridLinesRange (strRng)

'Merge multiple cells
ThisWorkbook.Worksheets(1).Range("$C$6:$J$" & lstRcl).Merge (True)
ThisWorkbook.Worksheets(1).Range("$M$6:$N$" & lstRcl).Merge (True)

'Make Thick border arround table header
DrawHeaderBorder ("B5:N5")

Cells(lstRcl + 2, 2) = "Deliver :"
Cells(lstRcl + 2, 11) = "Receiver :"

'Format cell K3 to Text
'Range("K3").NumberFormat = "@"

End Sub
'To fit to page
Sub PrintColumns()
    'Application.PrintCommunication = False
    With ThisWorkbook.Worksheets("Sheet1").PageSetup
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
    End With
    'Application.PrintCommunication = True
End Sub

Private Function LastRowFromClosedFile(InFolder As String, InFile As String, OnSheet As String, Optional FromCell As String = "A1", Optional InColumn As Long = 1) As Long

' Created 2018-11-22 by Timothy Daniel Cox
'
' Returns the LastRow on a given sheet from a closed file: returns "-1" if there was an error

On Error GoTo ErrorHandler
    Dim ShNew As Worksheet
    Application.DisplayAlerts = False
    Set ShNew = ThisWorkbook.Worksheets.Add
    With ShNew.Range("B6")
        .FormulaR1C1 = "=COUNTA('" & InFolder & "[" & InFile & "]" & OnSheet & "'!C" & InColumn & ")"
        LastRowFromClosedFile = .Value + 5 '+5 for first 5 rows where is no data for goods - only attributes for protocol
    End With
    ShNew.Delete
    Application.DisplayAlerts = True
Exit Function
ErrorHandler:
    Err.Clear
    LastRowFromClosedFile = -1
End Function

'Based on  VBA for gridlines over a range from : https://www.mrexcel.com/board/threads/vba-for-gridlines-over-a-range.505067/
Private Function DrawGridLinesRange(rng As String)
    Dim v As Variant
 
    With Range(rng)
        .Borders.LineStyle = xlNone
 
        For Each v In Array(xlEdgeLeft, xlEdgeTop, xlEdgeBottom, xlEdgeRight, xlInsideVertical, xlInsideHorizontal)
            With .Borders(v)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
        Next v
    End With
End Function

'Function for draing table header
Private Function DrawHeaderBorder(rang As String)
    Dim iRange As Range
    Dim iCells As Range

    Set iRange = Range(rang)

    For Each iCells In iRange
        iCells.BorderAround _
            Weight:=xlThick
    Next iCells
End Function

And here how it’s look like in action :