Sub ExcelGridtoPPBoxes()
            
    Call doExcelGridtoPPBoxes
    
End Sub

Sub doExcelGridtoPPBoxes(Optional ByVal p_firstrowhdr As Boolean = True, _
            Optional ByVal p_font As String = "Arial", _
            Optional ByVal p_fontsize As Integer = "10", _
            Optional ByVal p_left As Integer = "50", _
            Optional ByVal p_top As Integer = "10", _
            Optional ByVal p_width As Integer = "150", _
            Optional ByVal p_height As Integer = "20", _
            Optional ByVal p_margin As Integer = "20", _
            Optional ByVal p_folder As String = "%USERPROFILE%\Documents", _
            Optional ByVal p_nameprefix As String = "ExceltoPPExample")
    
    ' PowerPoint variables
    Dim pptApp  As Object, pptPres As Object, pptSlide As Object, pptShape As Object, pptPrevShape As Object, pptConnector As Object
    Dim pptFilename As String
    
    ' Boundary variables
    Dim firstdatarow, lastrow, lastcol As Integer
    
    If p_firstrowhdr = True Then
        firstdatarow = 2
    Else
        firstdatarow = 1
    End If
    
    ' Positional variables
    Dim left, top As Integer
    
    ' Counters
    Dim i, j As Integer
    
    ' Generate the full file path, ensuring the path and name are constructed correctly with '\' and '_'
    If Right(p_folder, 1) <> "\" Then
        p_folder = p_folder & "\"
    End If
    
    If Right(p_nameprefix, 1) <> "_" Then
        p_nameprefix = p_nameprefix & "_"
    End If
    
    pptFilename = p_folder & p_nameprefix & Format(Now, "yyyymmdd_hhmm  ss") & ".pptx"
    
    ' Get last populated row and column
    lastrow = Cells.SpecialCells(xlCellTypeLastCell).Row
    lastcol = Cells.SpecialCells(xlCellTypeLastCell).Column
    
    ' Create a new instance of PowerPoint application
    Set pptApp = CreateObject("PowerPoint.Application")
    pptApp.Visible = True
    
    ' Create a new presentation
    Set pptPres = pptApp.Presentations.Add
    
    ' Add a slide to the presentation (in Tools -> References add 'Microsoft PowerPoint xx.x Object Library)
    pptPres.Slides.Add Index:=1, Layout:=ppLayoutBlank
    Set pptSlide = pptPres.Slides(1)
    
    'Print the header boxes if the first row of the Excel grid is a header row
    left = p_left
    
    If p_firstrowhdr = True Then
        For i = 1 To lastcol
            Set pptShape = pptSlide.Shapes.AddShape(Type:=msoShapeRectangle, left:=left, top:=p_top, width:=p_width, height:=p_height)
            With pptShape
                .Fill.ForeColor.RGB = RGB(128, 0, 0)
                With .TextFrame.TextRange
                .Text = "[TBC]"
                    With .font
                    .Name = p_font
                    .Size = p_fontsize
                    .Bold = msoFalse
                    .Italic = msoFalse
                    .Underline = msoFalse
                    .Shadow = msoFalse
                    .Emboss = msoFalse
                    .BaselineOffset = 0
                    .AutorotateNumbers = msoFalse
                    End With
                End With
            End With
            ' Write to the shape
            pptShape.TextFrame.TextRange.Text = ActiveSheet.Cells(1, i)
            left = left + p_width + p_margin
        Next i
    End If
    
    ' Print each 'node' row with connecting arrows
    If p_firstrowhdr = True Then
        top = p_top + p_height + p_margin
    Else
        top = p_top
    End If
    
    For i = firstdatarow To lastrow
        left = p_left
        For j = 1 To lastcol
            If ActiveSheet.Cells(i, j) <> "" Then
                Set pptShape = pptSlide.Shapes.AddShape(Type:=msoShapeRectangle, left:=left, top:=top, width:=p_width, height:=p_height)
                With pptShape
                    With .TextFrame.TextRange
                    .Text = "[TBC]"
                        With .font
                        .Name = p_font
                        .Size = p_fontsize
                        .Bold = msoFalse
                        .Italic = msoFalse
                        .Underline = msoFalse
                        .Shadow = msoFalse
                        .Emboss = msoFalse
                        .BaselineOffset = 0
                        .AutorotateNumbers = msoFalse
                        End With
                    End With
                End With
                ' Write to the shape
                pptShape.TextFrame.TextRange.Text = ActiveSheet.Cells(i, j)
                ' Draw the connector between the current shape and the previous shape
                If j > 1 Then
                    Set pptConnector = pptSlide.Shapes.AddConnector(msoConnectorStraight, _
                                                                    BeginX:=left - p_margin, _
                                                                    BeginY:=(top + (p_height / 2)), _
                                                                    EndX:=left, _
                                                                    EndY:=(top + (p_height / 2)))
                    With pptConnector
                        .ConnectorFormat.BeginConnect ConnectedShape:=pptPrevShape, ConnectionSite:=4
                        .ConnectorFormat.EndConnect ConnectedShape:=pptShape, ConnectionSite:=2
                        .Line.ForeColor.RGB = RGB(255, 0, 0) ' Red fill
                        .Line.EndArrowheadStyle = msoArrowheadOpen
                        .Line.Weight = 1
                    End With
                    
                End If
            End If
            left = left + p_width + p_margin
            Set pptPrevShape = pptShape
        Next j
        top = top + p_height + p_margin
    Next i
    
    ' Save the presentation to the specified location
    pptPres.SaveAs pptFilename
    
End Sub

savename.sql