AutomatingTranslation of text as well as numbers in worksheet cells from one language to other using internet explorer and vba

Option Explicit

Function GetNumeric(CellRef As String)
Dim StringLength As Integer, i As Integer, result As String


StringLength = Len(CellRef)
For i = 1 To StringLength
If IsNumeric(Mid(CellRef, i, 1)) Then result = result & Mid(CellRef, i, 1)
Next i
GetNumeric = result
End Function


Sub test()
Sheets("Sheet2").Select
Range("A1").Select
'MsgBox (GetNumeric(ActiveCell.Value))
While ActiveCell.Value <> ""


ActiveCell.Offset(0, 1).Value = Replace(ActiveCell.Value, GetNumeric(ActiveCell.Value), LCase(NumToWords(GetNumeric(ActiveCell.Value))))
ActiveCell.Offset(0, 2).Value = translate_using_vba(ActiveCell.Offset(0, 1).Value, "bn")
ActiveCell.Offset(1, 0).Select
Wend

ActiveSheet.Cells.Columns.AutoFit

End Sub



      
'Main Function
Function NumToWords(ByVal MyNumber)
    
    'Written by Philip Treacy
    'http://www.myonlinetraininghub.com/convert-numbers-currency-to-words-with-excel-vba
    'Feb 2014
    'Based on code from Microsoft http://support.microsoft.com/kb/213360
    'This code is not guaranteed to be error free.  No warranty is implied or expressed. Use at your own risk and carry out your own testing
    
    Dim Units As String
    Dim SubUnits As String
    Dim TempStr As String
    Dim DecimalPlace As Integer
    Dim Count As Integer
    Dim DecimalSeparator As String
    Dim UnitName As String
    Dim SubUnitName As String
    Dim SubUnitSingularName As String
    
    DecimalSeparator = "."
    
    ReDim Place(9) As String
    Place(2) = " Thousand "
    Place(3) = " Million "
    Place(4) = " Billion "
    Place(5) = " Trillion "
            
    ' Convert MyNumber to STRING and TRIM white space
    MyNumber = Trim(CStr(MyNumber))
        
    'If MyNumber is blank then exit
    If MyNumber = "" Then
    
        NumToWords = ""
        
        Exit Function
    
    End If
        
    ' Find Position of decimal place, 0 if none.
    DecimalPlace = InStr(MyNumber, DecimalSeparator)
    
    
    ' Convert SubUnits and set MyNumber to Units amount.
    If DecimalPlace > 0 Then
    
        SubUnits = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2))
        MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
        
    End If
    
    
    Count = 1
    Do While MyNumber <> ""
        
        TempStr = GetHundreds(Right(MyNumber, 3))
        
        If TempStr <> "" Then Units = TempStr & Place(Count) & Units
        
        If Len(MyNumber) > 3 Then
        
            MyNumber = Left(MyNumber, Len(MyNumber) - 3)
            
        Else
            
            MyNumber = ""
            
        End If
        
        Count = Count + 1
        
    Loop
    
    NumToWords = Application.Trim(Units)
    
End Function
      
      
' Converts a number from 100-999 into text
Function GetHundreds(ByVal MyNumber)
    
    Dim result As String
    
    If Val(MyNumber) = 0 Then Exit Function
    
    MyNumber = Right("000" & MyNumber, 3)
    
    ' Convert the hundreds place.
    If Mid(MyNumber, 1, 1) <> "0" Then
        
        result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred "
           
    End If
    
           
    ' Convert the tens and ones place.
    If Mid(MyNumber, 2, 1) <> "0" Then
        
        result = result & GetTens(Mid(MyNumber, 2))
        
    Else
    
        result = result & GetDigit(Mid(MyNumber, 3))
        
    End If
    
    GetHundreds = result
    
End Function
      
' Converts a number from 10 to 99 into text.
Function GetTens(TensText)

    Dim result As String
    
    result = ""           ' Null out the temporary function value.
    
    If Val(Left(TensText, 1)) = 1 Then   ' If value between 10-19...
        
        Select Case Val(TensText)
            
            Case 10: result = "Ten"
            Case 11: result = "Eleven"
            Case 12: result = "Twelve"
            Case 13: result = "Thirteen"
            Case 14: result = "Fourteen"
            Case 15: result = "Fifteen"
            Case 16: result = "Sixteen"
            Case 17: result = "Seventeen"
            Case 18: result = "Eighteen"
            Case 19: result = "Nineteen"
            Case Else
        
        End Select
        
    Else                                 ' If value between 20-99...
        
        Select Case Val(Left(TensText, 1))
            
            Case 2: result = "Twenty "
            Case 3: result = "Thirty "
            Case 4: result = "Forty "
            Case 5: result = "Fifty "
            Case 6: result = "Sixty "
            Case 7: result = "Seventy "
            Case 8: result = "Eighty "
            Case 9: result = "Ninety "
            Case Else
        
        End Select
        
        result = result & GetDigit(Right(TensText, 1))   ' Retrieve ones place.
        
    End If
    
    GetTens = result
    
End Function
     
' Converts a number from 1 to 9 into text.
Function GetDigit(Digit)

    Select Case Val(Digit)
    
        Case 1: GetDigit = "One"
        Case 2: GetDigit = "Two"
        Case 3: GetDigit = "Three"
        Case 4: GetDigit = "Four"
        Case 5: GetDigit = "Five"
        Case 6: GetDigit = "Six"
        Case 7: GetDigit = "Seven"
        Case 8: GetDigit = "Eight"
        Case 9: GetDigit = "Nine"
        Case Else: GetDigit = ""
        
    End Select
    
End Function
Function translate_using_vba(str, langchoice) As String
' Tools Refrence Select Microsoft internet Control


    Dim IE As Object, i As Long
    Dim inputstring As String, outputstring As String, text_to_convert As String, result_data As String
    Dim CLEAN_DATA
    
    
    
    
    
    

    Set IE = CreateObject("InternetExplorer.application")
    '   TO CHOOSE INPUT LANGUAGE

    inputstring = "auto"

    '   TO CHOOSE OUTPUT LANGUAGE

    outputstring = langchoice

    text_to_convert = str

    'open website

    IE.Visible = False
    
    
    
    
    IE.navigate "http://translate.google.com/#" & inputstring & "/" & outputstring & "/" & text_to_convert

    Do Until IE.ReadyState = 4
        DoEvents
    Loop

    Application.Wait (Now + TimeValue("0:00:10"))
Do Until IE.ReadyState = 4
        DoEvents
    Loop
    
    IE.Quit
    translate_using_vba = IE.Document.getElementsByclassname("tlid-translation translation")(0).outertext
    



    

End Function

Adding a reference ,using it and remove the reference at the end programmatically using VBA

 

 

 

Most common Office GUID:

Microsoft Excel	{00020813-0000-0000-C000-000000000046}
Microsoft Word	{00020905-0000-0000-C000-000000000046}
Microsoft PowerPoint	{91493440-5A91-11CF-8700-00AA0060263B}
Microsoft Access	{4AFFC9A0-5F99-101B-AF4E-00AA003F0F07}
Microsoft Outlook	{00062FFF-0000-0000-C000-000000000046}

 

 

 

 

 

 

 

' ----------------------------------------------------------------
' Purpose: Add Microsoft Outlook Object Library, call a procedure using that library, then remove Outlook Object Library
' ----------------------------------------------------------------
Sub callingProcedureMSOutlookObjLibrary()

    Dim strGUID As String

    'Microsoft Outlook GUID
    strGUID = "{00062FFF-0000-0000-C000-000000000046}"

    'Check if reference is already added to the project, if not add it
    If F_isReferenceAdded(strGUID) = False Then
        ThisWorkbook.VBProject.REFERENCES.AddFromGuid strGUID, 0, 0
    End If
    
    'Calling the procedure using Outlook object library
    Call procedureUsingMSOutlookObjectLibrary
    
    'Check if reference is added to the project, if yes remove
    If F_isReferenceAdded(strGUID) = True Then
        ThisWorkbook.VBProject.REFERENCES.Remove F_idReferenceByGUID(strGUID)
    End If
    
End Sub
' ----------------------------------------------------------------
' Purpose: Create new Outlook document with early binding, add two paragraphs, align the 2nd one to center
' ----------------------------------------------------------------

'sending mail with pdf attachments


Sub procedureUsingMSOutlookObjectLibrary()


Dim olapp As Outlook.Application
Dim olemail As Outlook.MailItem
Dim objFSO As Object
Dim objFldr As Object
Dim objFile  As Object
Dim strfullpath As String
Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFldr = objFSO.GetFolder(Environ("UserProfile") & "\Desktop\excel_to_pdf_2")

Set olapp = New Outlook.Application
Set olemail = olapp.CreateItem(olMailItem)

With olemail

.BodyFormat = olFormatHTML

.Display
.HTMLBody = "Dear Someone" & "<br>" & .HTMLBody
'.Attachments.Add Environ("UserProfile") & "\Desktop\excel_to_pdf_2\Financial Sample.Canada.20200920_022807.pdf"
For Each objFile In objFldr.Files
        strfullpath = objFldr.Path & "\" & objFile.Name

        If LCase(Trim(objFSO.GetExtensionName(strfullpath))) = "pdf" Then
        'MsgBox strfullpath
            'SendasAttachment (strfullpath)
          .Attachments.Add strfullpath
        End If
    Next

.To = "allsourav2@gmail.com"
.Subject = "Test using VBA"
.Send




End With
Set olapp = Nothing
Set olemail = Nothing
End Sub

' ----------------------------------------------------------------
' Purpose: Check if an Object Library refernce is added to a VBAProject or not
' ----------------------------------------------------------------
Function F_isReferenceAdded(referenceGUID As String) As Boolean

    Dim varRef As Variant

    'Loop through VBProject references if input GUID found return TRUE otherwise FALSE
    For Each varRef In ThisWorkbook.VBProject.REFERENCES
        
        If varRef.GUID = referenceGUID Then
            F_isReferenceAdded = True
            Exit For
        End If
        
    Next varRef

End Function
' ----------------------------------------------------------------
' Purpose: Return Object Library reference as object, found by its GUID
' ----------------------------------------------------------------
Function F_idReferenceByGUID(referenceGUID As String) As Object

    Dim varRef As Object

    For Each varRef In ThisWorkbook.VBProject.REFERENCES
        
        If varRef.GUID = referenceGUID Then
            Set F_idReferenceByGUID = varRef
            Exit For
        End If
        
    Next varRef

End Function

Source:https://www.excelcise.org/add-or-remove-object-library-reference-via-vba/

Get unique values from a column of a range and filter the range by those unique values one by one and save the filtered results as pdfs and send mail with those pdfs as attachments using VBA

 Function RemoveDupesColl(MyArray As Variant) As Variant
'DESCRIPTION: Removes duplicates from your array using the collection method.
'NOTES: (1) This function returns unique elements in your array, but
' it converts your array elements to strings.

'-----------------------------------------------------------------------
    Dim I As Long
    Dim arrColl As New Collection
    Dim arrDummy() As Variant
    Dim arrDummy1() As Variant
    Dim item As Variant
    ReDim arrDummy1(LBound(MyArray) To UBound(MyArray))

    For I = LBound(MyArray) To UBound(MyArray) 'convert to string
        arrDummy1(I) = CStr(MyArray(I))
    Next I
    On Error Resume Next
    For Each item In arrDummy1
       arrColl.Add item, item
    Next item
    Err.Clear
    ReDim arrDummy(LBound(MyArray) To arrColl.Count + LBound(MyArray) - 1)
    I = LBound(MyArray)
    For Each item In arrColl
       arrDummy(I) = item
       I = I + 1
    Next item
    RemoveDupesColl = arrDummy
End Function


Sub filterandpastedata()


Sheets("Sheet1").Select
If ActiveSheet.AutoFilterMode Or ActiveSheet.FilterMode Then
    On Error Resume Next
    ActiveSheet.ShowAllData
End If


Dim uniquedata()



'MsgBox (samplerange.Rows.Count)
ReDim Preserve uniquedata(ActiveSheet.Range("A2", ActiveSheet.Range("A2").End(xlDown)).Rows.Count)
'MsgBox (UBound(uniquedata))
Dim dict As Object
Dim length As Long
length = 0
Range("B2").Select
While ActiveCell.Value <> ""

uniquedata(length) = ActiveCell.Value
length = length + 1
ActiveCell.Offset(1, 0).Select
Wend

'For length = LBound(uniquedata) To UBound(uniquedata) - 1
'MsgBox (uniquedata(length))
'Next length
Dim uniquedatafinal()
uniquedatafinal = RemoveDupesColl(uniquedata)
'For length = LBound(uniquedatafinal) To UBound(uniquedatafinal) - 1
'MsgBox (uniquedatafinal(length))
'Next length


'now we found the unique names ,let us first delete anysheet containing such unique names and create sheets containing those names
Dim tempsheetname As String
 With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With
   
  For length = LBound(uniquedatafinal) To UBound(uniquedatafinal) - 1
tempsheetname = (uniquedatafinal(length))

For Each wks In Application.Worksheets
        If wks.Name = tempsheetname Then wks.Delete
    Next

Next length

 For length = LBound(uniquedatafinal) To UBound(uniquedatafinal) - 1
     cntsheets = Application.Sheets.Count
    Set NewSheet = Application.Worksheets.Add(After:=Worksheets(cntsheets))
    NewSheet.Name = uniquedatafinal(length)
    Next length
   
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With

'Now creating sheets is done ,let us go back the data sheet and remove any filter from the sheet
'creating the directory for pdf files

Dim output_file As String, ws_count, I As Integer
Dim path, folder As String
path = "C:\Users\allso\Desktop\excel_to_pdf_2"
folder = dir(path, vbDirectory)
If folder = vbNullString Then

       
                VBA.FileSystem.MkDir (path)
          

    Else

    

    End If
    
Sheets("Sheet1").Select



Dim dataforfilter As String
Dim strtime As String

For length = LBound(uniquedatafinal) To UBound(uniquedatafinal) - 1
dataforfilter = Replace(ActiveSheet.Range("A1").CurrentRegion.Address, "$", "")
'MsgBox (dataforfilter)
ActiveSheet.Range(dataforfilter).AutoFilter Field:=2, Criteria1:=uniquedatafinal(length), Operator:=xlFilterValues
'ActiveSheet.Range(dataforfilter).AutoFilter Field:=4, Criteria1:="=Yes", Operator:=xlFilterValues
'sort the filtered range by the column gross sales
dataforfilter = Replace(ActiveSheet.Range("A1").CurrentRegion.Address, "$", "")
'MsgBox (dataforfilter)
Range(dataforfilter).Sort Key1:=[h2], Order1:=xlDescending, Header:=xlYes
ActiveSheet.Range("A1").CurrentRegion.Select
Selection.Copy

Sheets(uniquedatafinal(length)).Select
'Range("A1").PasteSpecial xlPasteValues

Range("A1").PasteSpecial xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
        
'autofitting the columns
ActiveSheet.Cells.Columns.AutoFit
'removing the borders
'changing the font
 With ActiveSheet.Cells.Font
 
        .Name = "Georgia Pro"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With

ActiveSheet.Cells.Borders.LineStyle = xlLineStyleNone

'now saving the sheet as pdf

strtime = Format(Now(), "yyyymmdd\_hhmmss")
output_file = path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) & "." & ActiveSheet.Name & "." & strtime & ".pdf"

'setting the page setup

'ActiveSheet.PageSetup.CenterHeader = "&B&14" & "Financial Data for " & uniquedatafinal(length) & ""

'&""Courier New""

'determine it is am or pm

If Format(CDate(Now), "am/pm") = "am" Then


ActiveSheet.PageSetup.CenterHeader = "&B&14&""Arial Narrow""&K00B0F0" & "Financial Data for " & uniquedatafinal(length) & " on " & "&D" & "," & "&T" & " AM"
Else
ActiveSheet.PageSetup.CenterHeader = "&B&14&""Arial Narrow""&K00B0F0" & "Financial Data for " & uniquedatafinal(length) & " on " & "&D" & "," & "&T" & " PM"

End If

'this is for setting the right footer of print which will print as Page (number of current page) of Total Pages
ActiveSheet.PageSetup.RightFooter = "&B&10&""Arial Narrow""&K00B0F0" & "Page &P of &N"



'this commented out section works best with portrait printing
With ActiveSheet.PageSetup
.CenterHorizontally = True
'.CenterVertically = True
.BottomMargin = 50
.TopMargin = 50
.RightMargin = 10
.LeftMargin = 10
.Zoom = 50
.FitToPagesWide = 1
.FitToPagesTall = False
.PrintTitleRows = ActiveSheet.Rows(1).Address
.Orientation = xlPortrait
.PrintQuality = 2400
End With
'ActiveSheet.PrintPreview
'this section works best for landscape printing
'With ersheet.PageSetup
''for setting portrait or landscape
'.Orientation = xlLandscape
''these next two line will fit all columns in one page
'.FitToPagesWide = 1
'.FitToPagesTall = 1
''this line is responsible for continuing one fixed row on several print pages ,it is similar as excel freeze pane
'.PrintTitleRows = ersheet.Rows(1).Address
'End With
ActiveWorkbook.ActiveSheet.ExportAsFixedFormat xlTypePDF, output_file, xlQualityStandard, openafterpublish:=False
    
    
Sheets("Sheet1").Select
If ActiveSheet.AutoFilterMode Or ActiveSheet.FilterMode Then
    On Error Resume Next
    ActiveSheet.ShowAllData
End If

Next length

If ActiveSheet.AutoFilterMode Then

     ActiveSheet.AutoFilterMode = False

End If


'sending mail with pdf attachments



Dim olapp As Outlook.Application
Dim olemail As Outlook.MailItem
Dim objFSO As Object
    Dim objFldr As Object
    Dim objFile  As Object
Dim strfullpath As String
Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFldr = objFSO.GetFolder(Environ("UserProfile") & "\Desktop\excel_to_pdf_2")

Set olapp = New Outlook.Application
Set olemail = olapp.CreateItem(olMailItem)

With olemail

.BodyFormat = olFormatHTML

.Display
.HTMLBody = "Dear Someone" & "<br>" & .HTMLBody
'.Attachments.Add Environ("UserProfile") & "\Desktop\excel_to_pdf_2\Financial Sample.Canada.20200920_022807.pdf"
For Each objFile In objFldr.Files
        strfullpath = objFldr.path & "\" & objFile.Name

        If LCase(Trim(objFSO.GetExtensionName(strfullpath))) = "pdf" Then
        'MsgBox strfullpath
            'SendasAttachment (strfullpath)
          .Attachments.Add strfullpath
        End If
    Next

.To = "allsourav2@gmail.com"
.Subject = "Test using VBA"
.Send




End With
Set olapp = Nothing
Set olemail = Nothing
Set objFldr = Nothing
Set objFSO = Nothing

End Sub

Automating creation of salary structure floating bar chart using excel vba

 Option Explicit

Function Difference(r1 As Range, r2 As Range) As Range

Dim s As String

Dim ws As Worksheet

 

If Not (r1.Parent Is r2.Parent) Then Exit Function

On Error Resume Next

 

Set ws = Worksheets.Add

ws.Range(r1.Address) = 0

ws.Range(r2.Address).Clear

s = ws.Range(r1.Address).SpecialCells(xlCellTypeConstants).Address

Application.DisplayAlerts = False

ws.Delete

Application.DisplayAlerts = True

If s <> "" Then Set Difference = r1.Parent.Range(s)

End Function

Sub floating_bar_chart()

'so first we have to delete the sheet named HR_Chart

With Application

        .ScreenUpdating = False

        .DisplayAlerts = False

        .EnableEvents = False

    End With

   Dim achart As Chart

   

 

 For Each achart In ActiveWorkbook.Charts

    achart.Delete

  Next

   

'    With ThisWorkbook

'        Set wks = .Sheets.Add(After:=.Sheets(.Sheets.Count))

'        wks.Name = "HR_Chart"

'    End With

   

    With Application

        .ScreenUpdating = True

        .DisplayAlerts = True

        .EnableEvents = True

    End With

'first delete all charts in this sheet

Dim Chrt As ChartObject

For Each Chrt In ActiveSheet.ChartObjects

Chrt.Delete

Next

'Declare some variables

Sheets("Sheet1").Select

Dim DataRng As Range

'Dim series1name As String

'Dim series2name As String

'Dim series3name As String

'series1name = ActiveSheet.Range("F3").Value

'series2name = ActiveSheet.Range("F4").Value

'series3.Name = ActiveSheet.Range("F5").Value

Dim seriesnames()

Dim series()

ReDim Preserve seriesnames(0)

ReDim Preserve series(0)

ActiveSheet.Range("F3").Select

While ActiveCell.Value <> ""

ReDim Preserve seriesnames(UBound(seriesnames) + 1)

ReDim Preserve series(UBound(series) + 1)

Set seriesnames(UBound(seriesnames) - 1) = ActiveCell

Set series(UBound(series) - 1) = Difference(Range(Selection, Selection.End(xlToRight)), Selection)

ActiveCell.Offset(1, 0).Select

Wend

Dim counter As Integer

'For counter = 0 To (UBound(series) - 1)

'MsgBox (series(counter))

'

'Next counter

'Add a chart object, this would be an empty shell

Set Chrt = ActiveSheet.ChartObjects.Add(Left:=200, _

                                        Width:=800, _

                                        Height:=800, _

                                        Top:=50)

                                        

                                        

'set the chart name

Dim chartname As String

   

       

  

chartname = "hrchart"

Chrt.Name = chartname

'Add the series of data in your chart

 For counter = 0 To (UBound(series) - 1)

Chrt.Chart.SeriesCollection.NewSeries

 

Chrt.Chart.SeriesCollection(counter + 1).Name = "='" & ActiveSheet.Name & "'!" & seriesnames(counter).Address(, , xlR1C1)

    

    

    

Chrt.Chart.FullSeriesCollection(counter + 1).Values = "='" & ActiveSheet.Name & "'!" & series(counter).Address(, , xlR1C1)

    

Next counter

    Sheets("Sheet1").Select

    'Set Chrt = ActiveSheet.ChartObjects("hrchart")

    'moving the chart to a sheet named "HR_Chart"

    

    'Chrt.Chart.Location Where:=xlLocationAsNewSheet, Name:="HR_Chart"

    

    'move chart to new sheet at the end

   

    

  

   

  Chrt.Chart.Location Where:=xlLocationAsNewSheet, Name:="HR_Chart"

 

ActiveChart.Move After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)

'Chrt.Chart.Location xlLocationAsObject, "HR_Chart"

ActiveChart.ChartArea.Select

    ActiveChart.FullSeriesCollection(1).Select

    ActiveChart.ChartGroups(1).Overlap = 100

   

    ActiveChart.ChartGroups(1).GapWidth = 66

    

    ActiveChart.ChartArea.Select

    ActiveChart.FullSeriesCollection(3).Select

  

    With Selection.Format.Fill

        .Visible = msoTrue

        .ForeColor.ObjectThemeColor = msoThemeColorBackground1

        .ForeColor.TintAndShade = 0

        .ForeColor.Brightness = 0

        .Transparency = 0

        .Solid

    End With

    

     ActiveChart.Axes(xlValue).MajorGridlines.Select

    Selection.Delete

  

    'ActiveSheet.ChartObjects("hrchart").Activate

    ActiveChart.FullSeriesCollection(1).Select

    ActiveChart.FullSeriesCollection(1).ApplyDataLabels

    ActiveChart.FullSeriesCollection(2).Select

    ActiveChart.FullSeriesCollection(2).ApplyDataLabels

    ActiveChart.FullSeriesCollection(3).Select

    ActiveChart.FullSeriesCollection(3).ApplyDataLabels

    

    ActiveChart.FullSeriesCollection(2).Select

    With Selection.Format.Fill

        .Visible = msoTrue

        .ForeColor.RGB = RGB(204, 229, 255)

        .Solid

    End With

'    ActiveChart.FullSeriesCollection(2).DataLabels.Select

'

'    With Selection.Format.TextFrame2.TextRange.Font.Fill

'        .Visible = msoTrue

'        .ForeColor.ObjectThemeColor = msoThemeColorBackground1

'        .ForeColor.TintAndShade = 0

'        .ForeColor.Brightness = 0

'        .Transparency = 0

'        .Solid

'    End With

    ActiveChart.FullSeriesCollection(2).DataLabels.Format.TextFrame2.TextRange.Font.Fill.Visible = msoTrue

     ActiveChart.FullSeriesCollection(2).DataLabels.Format.TextFrame2.TextRange.Font.Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground1

      ActiveChart.FullSeriesCollection(2).DataLabels.Format.TextFrame2.TextRange.Font.Fill.ForeColor.TintAndShade = 0

       ActiveChart.FullSeriesCollection(2).DataLabels.Format.TextFrame2.TextRange.Font.Fill.ForeColor.Brightness = 0

        ActiveChart.FullSeriesCollection(2).DataLabels.Format.TextFrame2.TextRange.Font.Fill.Transparency = 0

         ActiveChart.FullSeriesCollection(2).DataLabels.Format.TextFrame2.TextRange.Font.Fill.Solid

         

         

         ActiveChart.Deselect

SendKeys "{ESC}"

DoEvents

         

End Sub