Modify Macro to copy paste 0 as blank in ppt

[vbanovice123]

Hi,

I have a macro that works perfectly when copying and pasting data tables into powerpoint. However there are two manual process thatis pending automation.

A range of cells D1:G61 have values like 0, 0.0 and 0.0% . We want the macro to copy and paste these values as blank cell when pasting into ppt.

The data table range needs expansion in the width to occupy the full slide in ppt .


Thanks
Best Regards,
vbanovice123


Below is the function to copy and paste:

Public Sub copy_range_sheet_qtr(sheet As String, rngname As String)
Dim rngCopy As Range
Dim rngDest As Range
On Error Resume Next
Set rngCopy = Sheets(sheet).Range(rngname)
On Error GoTo 0
' Make sure the range is valid
If rngCopy Is Nothing Then
MsgBox "Please select a worksheet range and try again.", vbExclamation, _
"No Range Selected"
Else
Application.ScreenUpdating = False
Workbooks.Open Filename:= _
"F:\Focus\MyFolder\Copy Paste Project\OnePagers_Templates\One Pagers_yr_qtr_viewHardCopy.xlsx"
Set rngDest = ActiveWorkbook.Sheets(sheet).Range("B1").Resize(rngCopy.Rows.Count, rngCopy.Columns.Count)
rngCopy.Copy
rngDest.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
rngDest.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
rngDest.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveWorkbook.Close SaveChanges:=True
Application.CutCopyMode = True 'Clear clipboard
Application.ScreenUpdating = True
End If

End Sub




Below are the dimensions . How can I expand the width only, should I put a bigger number for sr.width? I have not played around and tested with different numbers for the width. Guess would also need to change the ht as well.

Public Function copy_range(sheet, rngname, slide, arheight, arwidth, artop, arleft, vscale)
Sheets(sheet).Select
'Cells(rowStart, columnStart).Resize(row_count, columnCount).Select
Range(rngname).Select
' Make sure a range is selected
If Not TypeName(Selection) = "Range" Then
MsgBox "Please select a worksheet range and try again.", vbExclamation, _
"No Range Selected"
Else
' Reference existing instance of PowerPoint
Set PPApp = GetObject(, "Powerpoint.Application")
' Reference active presentation
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.ViewType = ppViewSlide
PPApp.ActiveWindow.View.GotoSlide (slide)
' Reference active slide
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
' Copy the range as a picture
Selection.CopyPicture Appearance:=xlScreen, _
Format:=xlPicture
' Paste the range
PPSlide.Shapes.Paste.Select

Set sr = PPApp.ActiveWindow.Selection.ShapeRange
sr.LockAspectRatio = msoFalse
' Resize:
sr.Width = arwidth
sr.Height = arheight
sr.Top = artop
sr.Left = arleft

'sr.ScaleHeight 0.9, msoFalse
sr.ScaleWidth vscale, msoFalse
'If sr.Width > 700 Then
'sr.Width = 700
If sr.Width > 520 Then
sr.Width = 520
Else: sr.Width = 511
End If
'If sr.Height > 420 Then
'sr.Height = 420
If sr.Height > 430 Then
sr.Height = 430
Else: sr.Height = 425
End If
' Realign:
sr.Align msoAlignCenters, True
sr.Align msoAlignMiddles, True
'sr.Top = atop
If sr.Top > 90 Then
sr.Top = 90
Else
sr.Top = 80
End If
'If aleft <> 0 Then
If aleft > 60 Then
sr.Left = 60
Else
sr.Left = 50
End If
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End If
End Function