Any help to modify the VBA code below so that it can add totals for each columns and also to remove "£" on attached mail merge document?
Code:
Sub MailMergeToDoc()
Application.ScreenUpdating = False
Dim s As Long, c As Long, r As Long, t As Long
Dim Tbl As Table, StrRDt As String, StrCDt As String, Rng As Range
Dim u As Long, v As Long, w As Long, x As Long
ActiveDocument.MailMerge.Execute
With ActiveDocument
For s = 1 To .Sections.Count ' - 1
Set Tbl = .Sections(s).Range.Tables(1)
With Tbl
.Range.ParagraphFormat.Alignment = wdAlignParagraphRight
.Rows.Alignment = wdAlignRowCenter
.Rows(1).HeadingFormat = True
.Rows(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
For c = 3 To 5
.Columns(c).PreferredWidthType = wdPreferredWidthPoints
.Columns(c).PreferredWidth = InchesToPoints(1)
Next
StrRDt = Split(.Cell(.Rows.Count, 1).Range.Text, vbCr)(0)
StrRDt = Split(StrRDt, "-")(1) & "-" & Split(StrRDt, "-")(2)
.Rows.Add: t = .Rows.Count
For r = t - 1 To 2 Step -1
StrCDt = Split(.Cell(r, 1).Range.Text, vbCr)(0)
StrCDt = Split(StrCDt, "-")(1) & "-" & Split(StrCDt, "-")(2)
If StrRDt = StrCDt Then
For c = 3 To 5
Select Case c
Case 3: u = u + Split(Split(.Cell(r, c).Range.Text, vbCr)(0), "£")(1)
Case 4: v = v + Split(Split(.Cell(r, c).Range.Text, vbCr)(0), "£")(1)
Case 5: w = w + Split(Split(.Cell(r, c).Range.Text, vbCr)(0), "£")(1)
End Select
Next
ElseIf (StrRDt <> StrCDt) Or (r = 2) Then
.Cell(t, 1).Range.Text = StrRDt
.Rows(t).Range.Font.Italic = True
For c = 3 To 5
Select Case c
Case 3
.Cell(t, c).Range.Text = Format(u, "£#,##0")
u = Split(Split(.Cell(r, c).Range.Text, vbCr)(0), "£")(1)
Case 4
.Cell(t, c).Range.Text = Format(v, "£#,##0")
v = Split(Split(.Cell(r, c).Range.Text, vbCr)(0), "£")(1)
Case 5
.Cell(t, c).Range.Text = Format(w, "£#,##0")
w = Split(Split(.Cell(r, c).Range.Text, vbCr)(0), "£")(1)
End Select
Next
StrRDt = StrCDt: t = r + 1
If r <> 2 Then
.Rows.Add Tbl.Rows(r + 1)
Else
Exit For
End If
End If
Next
.Cell(t, 1).Range.Text = StrRDt
For c = 3 To 5
Select Case c
Case 3
.Cell(t, c).Range.Text = Format(u, "£#,##0")
Case 4
.Cell(t, c).Range.Text = Format(v, "£#,##0")
Case 5
.Cell(t, c).Range.Text = Format(w, "£#,##0")
End Select
Next
.Rows(t).Range.Font.Italic = True
.Rows.Add: t = .Rows.Count
For c = 3 To 5
Set Rng = .Cell(t, c).Range
Rng.Collapse wdCollapseStart
Rng.Fields.Add Rng, wdFieldEmpty, "=SUM(ABOVE)/2 \# £,#0", False
Next
.Cell(t, 1).Range.Text = "TOTAL:"
.Rows(t).Range.Font.Bold = True
End With
Set Tbl = .Sections(s).Range.Tables(2)
With Tbl
.Range.ParagraphFormat.Alignment = wdAlignParagraphRight
.Rows.Alignment = wdAlignRowCenter
.Rows(1).HeadingFormat = True
.Rows(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
StrRDt = Split(.Cell(.Rows.Count, 1).Range.Text, vbCr)(0)
StrRDt = Split(StrRDt, "-")(1) & "-" & Split(StrRDt, "-")(2)
.Rows.Add: t = .Rows.Count
For r = t - 1 To 2 Step -1
StrCDt = Split(.Cell(r, 1).Range.Text, vbCr)(0)
StrCDt = Split(StrCDt, "-")(1) & "-" & Split(StrCDt, "-")(2)
If StrRDt = StrCDt Then
x = x + Split(Split(.Cell(r, 2).Range.Text, vbCr)(0), "£")(1)
ElseIf (StrRDt <> StrCDt) Or (r = 2) Then
.Cell(t, 1).Range.Text = StrRDt
.Rows(t).Range.Font.Italic = True
.Cell(t, 2).Range.Text = Format(x, "£#,##0")
StrRDt = StrCDt: t = r + 1
If r <> 2 Then
.Rows.Add Tbl.Rows(r + 1)
Else
Exit For
End If
End If
Next
.Cell(t, 1).Range.Text = StrRDt
.Cell(t, 2).Range.Text = Format(x, "£#,##0")
.Rows(t).Range.Font.Italic = True
.Rows.Add: t = .Rows.Count
Set Rng = .Cell(t, 2).Range
Rng.Collapse wdCollapseStart
Rng.Fields.Add Rng, wdFieldEmpty, "=SUM(ABOVE)/2 \# £,#0", False
.Cell(t, 1).Range.Text = "TOTAL:"
.Rows(t).Range.Font.Bold = True
End With
Next
.Fields.Unlink
End With
Application.ScreenUpdating = True
End Sub