MS Excel, MS Word, MS Power Point, MS Outlook Macros
Playlists
Macros Lists: MS Excel, MS Word, MS PowerPoint, MS Outlook Macros
The second macro is recommended because it highlights every occurrence of the maximum value, rather than only the first one.
Great! Here's a more robust VBA macro that:
- Works on the active workbook and active worksheet
- Finds the largest numeric value in Column A
- Clears any existing fill color in Column A
- Highlights all cells containing the largest value with Yellow
- Ignores blank and non-numeric cells
- Displays a confirmation message
Sub HighlightLargestNumbersInColumnA()
Dim ws As Worksheet
Dim lastRow As Long
Dim maxValue As Double
Dim cell As Range
Dim foundNumber As Boolean
Dim countHighlighted As Long
Set ws = ActiveWorkbook.ActiveSheet
'Find last used row in Column A
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'Clear previous fill color
ws.Range("A1:A" & lastRow).Interior.Pattern = xlNone
foundNumber = False
'Find the maximum numeric value
For Each cell In ws.Range("A1:A" & lastRow)
If IsNumeric(cell.Value) And cell.Value <> "" Then
If Not foundNumber Then
maxValue = cell.Value
foundNumber = True
ElseIf cell.Value > maxValue Then
maxValue = cell.Value
End If
End If
Next cell
If Not foundNumber Then
MsgBox "No numeric values found in Column A.", vbExclamation
Exit Sub
End If
'Highlight all largest values
countHighlighted = 0
For Each cell In ws.Range("A1:A" & lastRow)
If IsNumeric(cell.Value) Then
If cell.Value = maxValue Then
cell.Interior.Color = vbYellow
countHighlighted = countHighlighted + 1
End If
End If
Next cell
MsgBox countHighlighted & " cell(s) highlighted." & vbCrLf & _
"Largest value = " & maxValue, vbInformation
End Sub
Features
- ✅ Uses the active worksheet.
- ✅ Clears previous highlights before applying new ones.
- ✅ Highlights all cells containing the maximum value.
- ✅ Ignores text, blanks, and errors.
- ✅ Shows the maximum value and the number of highlighted cells.
Highlight the Top 5 largest numbers
The following VBA macro highlights the Top 5 largest unique numeric values in Column A of the active worksheet.
Features
- ✅ Works on the active workbook and active worksheet
- ✅ Clears previous highlights in Column A
- ✅ Ignores blanks, text, and errors
- ✅ Highlights all occurrences of the Top 5 largest values (if duplicates exist)
- ✅ Uses Yellow fill
Sub HighlightTop5LargestNumbersInColumnA()
Dim ws As Worksheet
Dim lastRow As Long
Dim rng As Range, cell As Range
Dim dict As Object
Dim arr() As Double
Dim i As Long, j As Long
Dim temp As Double
Dim topCount As Long
Set ws = ActiveWorkbook.ActiveSheet
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Set rng = ws.Range("A1:A" & lastRow)
'Clear previous highlighting
rng.Interior.Pattern = xlNone
'Store unique numeric values
Set dict = CreateObject("Scripting.Dictionary")
For Each cell In rng
If IsNumeric(cell.Value) And Not IsEmpty(cell.Value) Then
If Not dict.Exists(CDbl(cell.Value)) Then
dict.Add CDbl(cell.Value), True
End If
End If
Next cell
If dict.Count = 0 Then
MsgBox "No numeric values found.", vbExclamation
Exit Sub
End If
'Copy dictionary keys to array
ReDim arr(dict.Count - 1)
For i = 0 To dict.Count - 1
arr(i) = dict.Keys()(i)
Next i
'Sort array in descending order
For i = LBound(arr) To UBound(arr) - 1
For j = i + 1 To UBound(arr)
If arr(j) > arr(i) Then
temp = arr(i)
arr(i) = arr(j)
arr(j) = temp
End If
Next j
Next i
topCount = Application.Min(5, UBound(arr) + 1)
'Highlight all cells matching the Top 5 values
For Each cell In rng
If IsNumeric(cell.Value) Then
For i = 0 To topCount - 1
If CDbl(cell.Value) = arr(i) Then
cell.Interior.Color = vbYellow
Exit For
End If
Next i
End If
Next cell
MsgBox "Top " & topCount & " largest value(s) highlighted.", vbInformation
End Sub
Example
If Column A contains:
| A |
|---|
| 15 |
| 80 |
| 45 |
| 80 |
| 25 |
| 100 |
| 90 |
| 75 |
| 60 |
| 90 |
The macro highlights all cells containing:
- 100
- 90 (both occurrences)
- 80 (both occurrences)
- 75
- 60
This is based on the Top 5 unique values.
----------------------------------------------------------------------------------------
1. Function NumberToWordsForPaise_NGR(ByVal MyNumber)
----------------------------------------------------------------------------------------
2. Function WordsToNumber_Paise(ByVal txt As String) As Double
' --- Convert text like "One Hundred Twenty Three and Forty Five Paise Only" to 123.45 ---
'Done
Dim word As Variant
Dim numberMap As Object, tensMap As Object, scalesMap As Object
Dim total As Double: total = 0
Dim current As Double: current = 0
Dim paise As Double: paise = 0
Dim isPaisePart As Boolean: isPaisePart = False
' Clean common terms
txt = Replace(txt, "-", " ")
txt = Replace(txt, "rupees", "")
txt = Replace(txt, "only", "")
txt = Replace(txt, " and ", " ~ ") ' Custom delimiter to split whole/paise
txt = Replace(txt, "paise", "")
txt = Replace(txt, "cents", "")
txt = Trim(txt)
' Split into main and paise part
If InStr(txt, "~") > 0 Then
mainPart = Trim(Split(txt, "~")(0))
paisePart = Trim(Split(txt, "~")(1))
Else
mainPart = txt
End If
' Prepare dictionaries for number lookup
Set tensMap = CreateObject("Scripting.Dictionary")
Set scalesMap = CreateObject("Scripting.Dictionary")
' Units
numberMap.Add "one", 1
numberMap.Add "two", 2
numberMap.Add "three", 3
numberMap.Add "four", 4
numberMap.Add "five", 5
numberMap.Add "six", 6
numberMap.Add "seven", 7
numberMap.Add "eight", 8
numberMap.Add "nine", 9
numberMap.Add "ten", 10
numberMap.Add "eleven", 11
numberMap.Add "twelve", 12
numberMap.Add "thirteen", 13
numberMap.Add "fourteen", 14
numberMap.Add "fifteen", 15
numberMap.Add "sixteen", 16
numberMap.Add "seventeen", 17
numberMap.Add "eighteen", 18
numberMap.Add "nineteen", 19
' Tens
tensMap.Add "thirty", 30
tensMap.Add "forty", 40
tensMap.Add "fifty", 50
tensMap.Add "sixty", 60
tensMap.Add "seventy", 70
tensMap.Add "eighty", 80
tensMap.Add "ninety", 90
' Scales
scalesMap.Add "thousand", 1000
scalesMap.Add "lakh", 100000
scalesMap.Add "million", 1000000
scalesMap.Add "crore", 10000000
' --- Function to process each part ---
FunctionValue = ConvertTextToNumber(mainPart, numberMap, tensMap, scalesMap)
total = FunctionValue
FunctionValue = ConvertTextToNumber(paisePart, numberMap, tensMap, scalesMap)
paise = FunctionValue
If paise > 0 Then
paise = paise / 100
End If
End If
End Function
' Helper function to convert number words into numeric value
Private Function ConvertTextToNumber(ByVal textPart As String, _
ByVal unitMap As Object, ByVal tensMap As Object, ByVal scaleMap As Object) As Double
tokens = Split(Trim(textPart))
Dim current As Double: current = 0
Dim result As Double: result = 0
If unitMap.Exists(word) Then
current = current + unitMap(word)
ElseIf tensMap.Exists(word) Then
current = current + tensMap(word)
ElseIf scaleMap.Exists(word) Then
If current = 0 Then current = 1
current = current * scaleMap(word)
result = result + current
current = 0
End If
Next word
ConvertTextToNumber = result
End Function
-------------------------------------------------------------------------------------------------
3. Outlook Mail Extract - I
Sub ExtractGmailInboxToExcel()
'Done
Dim OutlookNamespace As Object
Dim folder As Object
Dim OutlookMail As Object
Dim i As Integer
Dim row As Integer
' Create Outlook application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
' Select Gmail inbox - replace with your account name if needed
Set folder = OutlookNamespace.Folders("nagarajalingayath@gmail.com").Folders("Inbox")
' Setup Excel sheet
With ActiveSheet
.Cells(1, 1).Value = "Subject"
.Cells(1, 2).Value = "Sender"
.Cells(1, 3).Value = "Received Time"
End With
' Loop through emails
Set OutlookMail = folder.items(i)
If OutlookMail.Class = 43 Then ' Ensure it's a MailItem
With ActiveSheet
.Cells(row, 1).Value = OutlookMail.Subject
.Cells(row, 2).Value = OutlookMail.SenderName
.Cells(row, 3).Value = OutlookMail.ReceivedTime
End With
row = row + 1
End If
Next i
MsgBox "Inbox extraction complete!", vbInformation
End Sub
-------------------------------------------------------------------------------------------------
4. Outlook Mail Extract - II
Sub ExtractGmailInboxToExcel_NGR()
'Done
Dim OutlookNamespace As Object
Dim folder As Object
Dim OutlookMail As Object
Dim i As Long
Dim row As Integer
Dim ws As Worksheet
row = 2
' Header row
ws.Cells(1, 2).Value = "Sender"
ws.Cells(1, 3).Value = "Received Time"
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set folder = OutlookNamespace.Folders("nagarajalingayath@gmail.com").Folders("Inbox")
Set OutlookMail = folder.items(i)
If OutlookMail.Class = 43 Then
On Error Resume Next
ws.Cells(row, 1).Value = OutlookMail.Subject
ws.Cells(row, 2).Value = OutlookMail.SenderName
ws.Cells(row, 3).Value = OutlookMail.ReceivedTime
row = row + 1
On Error GoTo 0
End If
Next i
End Sub
-------------------------------------------------------------------------------------------------
5. Autofit Selected Column
Sub AutoFitSelectedColumn()
'Done
Dim rng As Range
' Set active worksheet
Set ws = ActiveSheet
' Check if any cell is selected
Selection.Columns.AutoFit
Else
MsgBox "Please select a column first.", vbExclamation, "No Selection"
End If
End Sub
-------------------------------------------------------------------------------------------------
6. Format Selected Column
Sub FormatSelectedColumn()
'Done
Dim rng As Range
Dim col As Range
' Set the active worksheet
Set ws = ActiveSheet
' Check if a range is selected
Set col = Selection.EntireColumn
' AutoFit column width
col.AutoFit
' Apply center alignment (horizontal and vertical)
col.VerticalAlignment = xlCenter
' Make the first row of the selected column bold (assuming headers are in the first row)
ws.Cells(1, col.Column).Font.Bold = True
MsgBox "Please select a column first.", vbExclamation, "No Selection"
End If
End Sub
-------------------------------------------------------------------------------------------------
7. Merge Selected Cells
Sub MergeSelectedCells()
'Done
' Check if a range is selected
MsgBox "Please select a range of cells to merge.", vbExclamation, "No Selection"
Exit Sub
End If
' Merge the selected cells
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End Sub
-------------------------------------------------------------------------------------------------
8. Align Text
Sub AlignText()
'Done
Dim hAlign As String
Dim vAlign As String
' Prompt user for horizontal alignment
hAlign = InputBox("Enter Horizontal Alignment (Left, Center, Right, Justify, Distributed):", "Horizontal Alignment")
' Prompt user for vertical alignment
vAlign = InputBox("Enter Vertical Alignment (Top, Center, Bottom, Justify, Distributed):", "Vertical Alignment")
' Apply the horizontal alignment
Case "left": Selection.HorizontalAlignment = xlLeft
Case "center": Selection.HorizontalAlignment = xlCenter
Case "right": Selection.HorizontalAlignment = xlRight
Case "justify": Selection.HorizontalAlignment = xlJustify
Case "distributed": Selection.HorizontalAlignment = xlDistributed
Case Else: MsgBox "Invalid Horizontal Alignment!", vbExclamation: Exit Sub
End Select
' Apply the vertical alignment
Case "top": Selection.VerticalAlignment = xlTop
Case "center": Selection.VerticalAlignment = xlCenter
Case "bottom": Selection.VerticalAlignment = xlBottom
Case "justify": Selection.VerticalAlignment = xlJustify
Case "distributed": Selection.VerticalAlignment = xlDistributed
Case Else: MsgBox "Invalid Vertical Alignment!", vbExclamation: Exit Sub
End Select
End Sub
-------------------------------------------------------------------------------------------------
9. Fill Down Selection
Sub FillDownSelection()
'Done
Dim fillRange As Range
' Set the active worksheet
Set ws = ActiveSheet
' Check if a range is selected
MsgBox "Please select a range to fill down.", vbExclamation
Exit Sub
End If
Set fillRange = Selection
' Make sure it's more than one row
MsgBox "Select at least two rows to perform a fill-down.", vbExclamation
Exit Sub
End If
' Fill down from the first cell in the selection
fillRange.FillDown
End Sub
-------------------------------------------------------------------------------------------------
10. Fill Down from Row Above Active Cell
Sub FillDownFromRowAboveActiveCell()
'Done
Dim activeRow As Long, activeCol As Long
Dim lastCol As Long, i As Long
Dim topRow As Long
Dim lastrow As Long
activeRow = ActiveCell.row
activeCol = ActiveCell.Column
MsgBox "You are in the first row. No row above to fill from.", vbExclamation
Exit Sub
End If
lastCol = ws.Cells(topRow, ws.Columns.count).End(xlToLeft).Column
lastrow = ws.Cells(ws.Rows.count, activeCol).End(xlUp).row
If ws.Cells(topRow, i).Value <> "" Then
' Fill down only if the cell above has value
If ws.Cells(activeRow, i).Value = "" Then
ws.Cells(activeRow, i).Value = ws.Cells(topRow, i).Value
End If
End If
Next i
End Sub
-------------------------------------------------------------------------------------------------
11. Hide Selected Column
Sub HideSelectedColumn()
'Done
' Check if a single cell is selected
If Not TypeName(Selection) = "Range" Then Exit Sub
' Hide the entire column of the selected cell
Selection.EntireColumn.Hidden = True
End Sub
-------------------------------------------------------------------------------------------------
12. Unhide Selected Column
Sub UnhideSelectedColumn()
'Done
' Loop through all columns to check if they are hidden
For Each col In Selection.EntireColumn
If col.EntireColumn.Hidden = True Then
col.EntireColumn.Hidden = False
End If
Next col
End Sub
-------------------------------------------------------------------------------------------------
13. Generate Static Random Times
Sub GenerateStaticRandomTimes()
Dim i As Long
' Define the range where times will be placed
Set rng = ThisWorkbook.Sheets("Sheet1").Range("B2:B10000")
For i = 1 To rng.Rows.count
Dim hr As Long, mn As Long, sc As Long
hr = WorksheetFunction.RandBetween(0, 23)
mn = WorksheetFunction.RandBetween(0, 59)
sc = WorksheetFunction.RandBetween(0, 59)
Next i
Application.ScreenUpdating = True
End Sub
-------------------------------------------------------------------------------------------------
14. Count Text - User-Defined function
Function CountText(ByVal FullText As String, ByVal FindText As String) As Long
Dim txt As String, find As String
Dim pos As Long, count As Long
' Convert both to lowercase for case-insensitive comparison
txt = LCase(FullText)
find = LCase(FindText)
' If FindText is empty, return 0
If Len(find) = 0 Then
CountText = 0
Exit Function
End If
' Loop to count occurrences
pos = InStr(1, txt, find)
Do While pos > 0
count = count + 1
pos = InStr(pos + Len(find), txt, find)
Loop
CountText = count
End Function
-------------------------------------------------------------------------------------------------
15. Dump - User-Defined Function
Function DumpChars(CellRef As Variant) As String
'Excellent
Dim i As Long
Dim result As String
Dim strVal As String
' Convert input to string so both numbers and text work
strVal = CStr(CellRef)
For i = 1 To Len(strVal)
result = result & Asc(Mid(strVal, i, 1)) & ","
Next i
' Remove last comma
If Right(result, 1) = "," Then
result = Left(result, Len(result) - 1)
End If
DumpChars = result
End Function
-------------------------------------------------------------------------------------------------
16. Dump Sum - User-Defined Function
Function DumpSum(CellRef As Variant) As Long
'Excellent
Dim i As Long
Dim strVal As String
Dim total As Long
strVal = CStr(CellRef)
For i = 1 To Len(strVal)
total = total + Asc(Mid(strVal, i, 1))
Next i
DumpSum = total
End Function
-------------------------------------------------------------------------------------------------
17. Copy Data with Conditions
Sub CopyDataWithConditions()
'Done
Dim wsSource As Worksheet ' Define the source worksheet (ActiveSheet)
Dim wsTarget As Worksheet ' Define the target worksheet
Dim lastrow As Long ' Variable to store the last row of data
Dim targetRow As Long ' Variable to store the next available row in the target sheet
Dim i As Long ' Loop variable
' Set the source (ActiveSheet) and target worksheet (change "TargetSheet" to your actual sheet name)
Set wsSource = ActiveSheet
Set wsTarget = ThisWorkbook.Sheets("TargetSheet") ' Modify with your sheet name
' Find the last row with data in the source sheet (Assumes data is in Column A)
lastrow = wsSource.Cells(wsSource.Rows.count, 1).End(xlUp).row
' Find the next available row in the target sheet
targetRow = wsTarget.Cells(wsTarget.Rows.count, 1).End(xlUp).row + 1
' Loop through each row in the source sheet
For i = 2 To lastrow ' Assuming row 1 contains headers
' Check multiple conditions (Modify conditions as needed)
If wsSource.Cells(i, 2).Value = "Approved" And wsSource.Cells(i, 3).Value >= 1000 Then
' Copy the entire row
wsSource.Rows(i).Copy
' Paste into the target sheet at the next available row
wsTarget.Cells(targetRow, 1).PasteSpecial Paste:=xlPasteValues
' Move to the next available row in the target sheet
targetRow = targetRow + 1
End If
Next i
' Clear the clipboard to prevent issues
Application.CutCopyMode = False
' Notify the user
MsgBox "Data copied successfully based on conditions!", vbInformation
End Sub
-------------------------------------------------------------------------------------------------
18. Clear Old Data
Sub CopyDataWithConditionsAndClearOldData()
'Done
Dim wsSource As Worksheet ' Define the source worksheet (ActiveSheet)
Dim wsTarget As Worksheet ' Define the target worksheet
Dim lastrow As Long ' Variable to store the last row in the source sheet
Dim targetRow As Long ' Variable to store the next available row in the target sheet
Dim i As Long ' Loop variable
Dim conditionDate As Date ' Variable for date condition
' Set the source (ActiveSheet) and target worksheet (change "TargetSheet" to your actual sheet name)
Set wsSource = ActiveSheet
Set wsTarget = ThisWorkbook.Sheets("TargetSheet") ' Modify with your sheet name
' Clear old data from Target Sheet (except headers in row 1)
wsTarget.Rows("2:" & wsTarget.Rows.count).ClearContents
' Find the last row with data in the source sheet (Assumes data is in Column A)
lastrow = wsSource.Cells(wsSource.Rows.count, 1).End(xlUp).row
' Set the starting row for pasting data in the target sheet
targetRow = 2 ' Assuming row 1 contains headers
' Define date filter condition (e.g., Only copy rows where date is within the last 30 days)
conditionDate = Date - 30 ' This checks if the date in column D is within the last 30 days
' Loop through each row in the source sheet
For i = 2 To lastrow ' Assuming row 1 contains headers
' Check multiple conditions:
' 1. Column B contains "Approved"
' 2. Column C has a value >= 1000
' 3. Column D (Date) is within the last 30 days
If wsSource.Cells(i, 2).Value = "Approved" And _
wsSource.Cells(i, 3).Value >= 1000 And _
wsSource.Cells(i, 4).Value >= conditionDate Then
' Copy the entire row
wsSource.Rows(i).Copy
' Paste into the target sheet at the next available row
wsTarget.Cells(targetRow, 1).PasteSpecial Paste:=xlPasteValues
' Move to the next available row in the target sheet
targetRow = targetRow + 1
End If
Next i
' Clear the clipboard to prevent issues
Application.CutCopyMode = False
' Notify the user
MsgBox "Data copied successfully based on conditions! Old data cleared.", vbInformation
End Sub
-------------------------------------------------------------------------------------------------
19. Toggle Column Visibility
Sub ToggleColumnVisibility()
'Done
' Check if a single cell is selected
If Not TypeName(Selection) = "Range" Then Exit Sub
' Check if the column is hidden
If Selection.EntireColumn.Hidden = True Then
Selection.EntireColumn.Hidden = False ' Unhide if hidden
Else
Selection.EntireColumn.Hidden = True ' Hide if visible
End If
End Sub
-------------------------------------------------------------------------------------------------
20. Exports Charts to PPT - I
Sub ExportChartsToPPT()
'Done
Dim pptApp As Object
Dim pptPres As Object
Dim pptSlide As Object
Dim pptShape As Object
Dim wb As Workbook
Dim ws As Worksheet
Dim chtObj As ChartObject
Dim sldIndex As Long
On Error Resume Next
Set pptApp = GetObject(Class:="PowerPoint.Application")
If pptApp Is Nothing Then
Set pptApp = CreateObject("PowerPoint.Application")
End If
On Error GoTo 0
pptApp.Visible = True
Set pptPres = pptApp.Presentations.Add
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
sldIndex = 1
For Each chtObj In ws.ChartObjects
' Add a new Title and Content slide
Set pptSlide = pptPres.Slides.Add(sldIndex, ppLayoutText)
pptSlide.Select
' Set slide title
pptSlide.Shapes(1).TextFrame.TextRange.Text = chtObj.Chart.ChartTitle.Text
' Copy chart
chtObj.Chart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
' Paste chart into slide content
pptSlide.Shapes.Paste.Select
Set pptShape = pptApp.ActiveWindow.Selection.ShapeRange
' Resize and center chart
With pptShape
.LockAspectRatio = msoTrue
.Width = 400
.Top = 150
.Left = (pptPres.PageSetup.SlideWidth - .Width) / 2
End With
sldIndex = sldIndex + 1
Next chtObj
MsgBox "All charts have been exported to PowerPoint.", vbInformation
End Sub
-------------------------------------------------------------------------------------------------
21. Exports Charts to PPT - II
Sub ExportChartsToPPT_NGR()
'Done
Dim pptApp As Object
Dim pptPres As Object
Dim pptSlide As Object
Dim pptShape As Object
Dim wb As Workbook
Dim ws As Worksheet
Dim chtObj As ChartObject
Dim sldIndex As Long
On Error Resume Next
Set pptApp = GetObject(Class:="PowerPoint.Application")
If pptApp Is Nothing Then
Set pptApp = CreateObject("PowerPoint.Application")
End If
On Error GoTo 0
pptApp.Visible = True
Set pptPres = pptApp.Presentations.Add
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
sldIndex = 1
For Each chtObj In ws.ChartObjects
' Add a new Title and Content slide
Set pptSlide = pptPres.Slides.Add(sldIndex, ppLayoutText)
pptSlide.Select
' Set slide title
pptSlide.Shapes(1).TextFrame.TextRange.Text = chtObj.Chart.ChartTitle.Text
' Copy chart
chtObj.Chart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
' Paste chart into slide content
pptSlide.Shapes.Paste.Select
Set pptShape = pptApp.ActiveWindow.Selection.ShapeRange
' Resize and center chart
With pptShape
.LockAspectRatio = msoTrue
.Width = 550
'.Height = pptPlaceholder.Height
.Top = 150
.Left = (pptPres.PageSetup.SlideWidth - .Width) / 2
End With
'With pptShape
'.LockAspectRatio = msoFalse
'.Left = (pptPres.PageSetup.SlideWidth - .Width) / 2
'.Top = pptPlaceholder.Top
'.Width = pptPlaceholder.Width
'.Height = pptPlaceholder.Height
'End With
sldIndex = sldIndex + 1
Next chtObj
MsgBox "All charts have been exported to PowerPoint.", vbInformation
End Sub
-------------------------------------------------------------------------------------------------
22. Export Charts to PPT Resize to content
Sub ExportChartsToPPT_ResizeToContent_N2()
'Done Perfect
Dim pptApp As Object
Dim pptPres As Object
Dim pptSlide As Object
Dim pptShape As Object
Dim pptPlaceholder As Object
Dim wb As Workbook
Dim ws As Worksheet
Dim chtObj As ChartObject
Dim sldIndex As Long
' Start PowerPoint
On Error Resume Next
Set pptApp = GetObject(Class:="PowerPoint.Application")
If pptApp Is Nothing Then
Set pptApp = CreateObject("PowerPoint.Application")
End If
On Error GoTo 0
pptApp.Visible = True
Set pptPres = pptApp.Presentations.Add
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
sldIndex = 1
For Each chtObj In ws.ChartObjects
' Add Title and Content slide
Set pptSlide = pptPres.Slides.Add(sldIndex, ppLayoutText)
pptSlide.Select
' Set slide title
pptSlide.Shapes(1).TextFrame.TextRange.Text = chtObj.Chart.ChartTitle.Text
' If chtObj.Chart.HasTitle Then
' pptSlide.Shapes(1).TextFrame.TextRange.Text = chtObj.Chart.ChartTitle.Text
' Else
' pptSlide.Shapes(1).TextFrame.TextRange.Text = "Chart " & sldIndex
' End If
' Center title horizontally and vertically
With pptSlide.Shapes(1).TextFrame
.HorizontalAnchor = msoAnchorCenter
.VerticalAnchor = msoAnchorMiddle
End With
With pptSlide.Shapes(1).TextFrame.TextRange.ParagraphFormat
.Alignment = ppAlignCenter
End With
' Copy chart
chtObj.Chart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
' Paste chart
pptSlide.Shapes.Paste.Select
Set pptShape = pptApp.ActiveWindow.Selection.ShapeRange
' Reference the content placeholder (Shape 2 is the content box)
Set pptPlaceholder = pptSlide.Shapes(2)
' Resize and position the chart exactly inside the placeholder
With pptShape
.LockAspectRatio = msoFalse
.Left = pptPlaceholder.Left
.Top = pptPlaceholder.Top
.Width = pptPlaceholder.Width
.Height = pptPlaceholder.Height
End With
sldIndex = sldIndex + 1
Next chtObj
MsgBox "All charts exported and resized to content placeholder.", vbInformation
End Sub
-------------------------------------------------------------------------------------------------
23. Export Charts to PPT Remove Chart Title
Sub ExportChartsToPPT_RemoveChartTitle()
'Done Perfect
Dim pptApp As Object
Dim pptPres As Object
Dim pptSlide As Object
Dim pptShape As Object
Dim pptPlaceholder As Object
Dim wb As Workbook
Dim ws As Worksheet
Dim chtObj As ChartObject
Dim sldIndex As Long
Dim chartTitleText As String
' Start PowerPoint
On Error Resume Next
Set pptApp = GetObject(Class:="PowerPoint.Application")
If pptApp Is Nothing Then
Set pptApp = CreateObject("PowerPoint.Application")
End If
On Error GoTo 0
pptApp.Visible = True
Set pptPres = pptApp.Presentations.Add
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
sldIndex = 1
For Each chtObj In ws.ChartObjects
' Save chart title text if it exists
If chtObj.Chart.HasTitle Then
chartTitleText = chtObj.Chart.ChartTitle.Text
chtObj.Chart.HasTitle = False ' Remove chart title before copying
Else
chartTitleText = "Chart " & sldIndex
End If
' Add Title and Content slide
Set pptSlide = pptPres.Slides.Add(sldIndex, ppLayoutText)
pptSlide.Select
' Set slide title text (centered)
pptSlide.Shapes(1).TextFrame.TextRange.Text = chartTitleText
With pptSlide.Shapes(1).TextFrame
.HorizontalAnchor = msoAnchorCenter
.VerticalAnchor = msoAnchorMiddle
End With
pptSlide.Shapes(1).TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
' Copy chart (now without title)
chtObj.Chart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
' Paste chart
pptSlide.Shapes.Paste.Select
Set pptShape = pptApp.ActiveWindow.Selection.ShapeRange
' Reference content placeholder (Shape 2)
Set pptPlaceholder = pptSlide.Shapes(2)
' Resize and position chart to placeholder
With pptShape
.LockAspectRatio = msoFalse
.Left = pptPlaceholder.Left
.Top = pptPlaceholder.Top
.Width = pptPlaceholder.Width
.Height = pptPlaceholder.Height
End With
sldIndex = sldIndex + 1
Next chtObj
MsgBox "All charts exported (chart titles removed).", vbInformation
End Sub
-------------------------------------------------------------------------------------------------
Comments
Post a Comment