macro to delete very first sheet of all excel files in a folder

 Sub RenameSheets()
     Dim strFolder As String
     Dim strFile As String
     Dim wbk As Workbook
     Dim i As Long
     With Application.FileDialog(4) ' msoFileDialogFolderPicker
         ' Show dialog
         If .Show Then
             ' Assign selected folder to variable
             strFolder = .SelectedItems(1)
         Else
             Beep
             Exit Sub
         End If
     End With
     ' Append \ if necessary
     If Right(strFolder, 1) <> "\" Then
         strFolder = strFolder & "\"
     End If
     On Error GoTo ErrHandler
     ' Turn off screen updating and event handling
     Application.ScreenUpdating = False
     Application.EnableEvents = False
     ' Get first file name in folder
     strFile = Dir(strFolder & "*.xls*")
     ' Loop
     Do While strFile <> ""
         ' Open workbook
         Set wbk = Workbooks.Open(Filename:=strFolder & strFile)
         ' Loop through sheets except first one
        ' For i = 2 To wbk.Worksheets.Count
            ' With wbk.Worksheets(i)
                 ' Append " Old" to sheet name
             '    .Name = .Name & " Old"
             'End With
         'Next i
         Application.DisplayAlerts = False
         If wbk.Worksheets.Count > 1 Then
         
         wbk.Worksheets(1).Delete
         End If
         
         Application.DisplayAlerts = True
           ' wbk.Close True
         ' Close and save workbook
         wbk.Close SaveChanges:=True
         ' Get next file name
         strFile = Dir
     Loop
ExitHandler:
     ' Turn on screen updating and event handling
     Application.EnableEvents = True
     Application.ScreenUpdating = True
     Exit Sub
ErrHandler:
     MsgBox Err.Description, vbExclamation
     Resume ExitHandler
 End Sub

Printing filtered data and stopping printing blank pages and fitting all columns in one page using vba

 Sub justprint()

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









'let us first delete anysheet containing name like Canada and create sheets named as Canada

 With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With
   
Dim wks, newsheet As Worksheet


For Each wks In Application.Worksheets
        If wks.name = "Canada" Then wks.Delete
    Next



 Dim cntsheets As Long
 
     cntsheets = Application.Sheets.Count
    Set newsheet = Application.Worksheets.Add(After:=Worksheets(cntsheets))
    newsheet.name = "Canada"

   

'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 mynetwork As Object


Dim dataforfilter As String
Dim strtime As String
'set current default printer
Set mynetwork = CreateObject("WScript.network")
mynetwork.setdefaultprinter "Adobe PDF"
Dim objAccess As Object
Set objAccess = CreateObject("Access.Application")
Dim prtLoop As Object
'get current default printer
Set prtLoop = objAccess.Printer
'now we can access the printquality supported by the default printer by using prtloop.printquality

dataforfilter = Replace(ActiveSheet.Range("A1").CurrentRegion.Address, "$", "")
'MsgBox (dataforfilter)
ActiveSheet.Range(dataforfilter).AutoFilter Field:=2, Criteria1:="Canada", 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("Canada").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


If Format(CDate(Now), "am/pm") = "am" Then
strtime = Format(Now(), "yyyymmdd\_hhmmss") & " AM"
Else
strtime = Format(Now(), "yyyymmdd\_hhmmss") & " PM"
End If

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 " & "Canada" & " on " & "&D" & "," & "&T" & " AM"
Else
ActiveSheet.PageSetup.CenterHeader = "&B&14&""Arial Narrow""&K00B0F0" & "Financial Data for " & "Canada" & " 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"

'change activeprinter to a choice of mine

'to set printarea manually we have to calculate the printarea using this lastrow
Dim lastrow As Long

lastrow = Application.WorksheetFunction.Subtotal(3, Range("P:P"))

'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
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
.PrintTitleRows = ActiveSheet.Rows(1).Address
.Orientation = xlPortrait
.PrintQuality = prtLoop.PrintQuality
.PrintArea = "A1:P" & lastrow

End With
'MsgBox (ActiveSheet.PageSetup.PrintArea.Address)
'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



If ActiveSheet.AutoFilterMode Then

     ActiveSheet.AutoFilterMode = False

End If

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With

End Sub

Source:https://stackoverflow.com/questions/25741049/how-to-set-fit-all-columns-on-one-page-in-print-tab

Source:https://stackoverflow.com/questions/17285897/row-count-on-the-filtered-data

Select and open an excel file using filedialog vba

 Dim wb As Workbook
  Dim wc, wd, oSheet As Worksheet
 
 ' Create and set the file dialog object.
    Dim fd As Office.FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    
    With fd
        .Filters.Clear
        .Title = "Select an Excel File"
        .Filters.Add "Excel Files", "*.xlsx?", 1
        .AllowMultiSelect = False
        .InitialFileName = "C:\Users\allso\Desktop\test"
        Dim sFile As String
    
        If .Show = True Then
            sFile = .SelectedItems(1)
        End If
    End With
    
    If sFile <> "" Then
       Set wb = Workbooks.Open(sFile)   ' Open the Excel file.
    End If

 'save and close the file

   wb.Close savechanges:=True

Freeze the top row using vba

 
    Rows("1:1").Select
    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
    End With
    ActiveWindow.FreezePanes = True

Create a new sheet at the end of all sheet with a name stored in a variable using vba

  

dim wd as worksheet

dim newsheetname as sring

newsheetname="NewSheet"

 

Set wd = .Sheets.Add(After:=.Sheets(.Sheets.Count))
    wd.Name = newsheetname
    End With

Remove duplcate values from an array using VBA

 arr1 = Range(Range("C13"), Range("C13").End(xlDown)).Value2
arr2 = Range(Range("E13"), Range("E13").End(xlDown)).Value2
'arr2 = ws.Range("E13:E25").Value2
    
arr3 = Split(Join(Application.Transpose(arr1), ",") & "," & Join(Application.Transpose(arr2), ","), ",")
'Debug.Print Join(arr3, ",")

Dim poArrNoDup()
Dim duparrindex As Integer

    duparrindex = -1
    For i = LBound(arr3) To UBound(arr3)
        dupBool = False

        For j = LBound(arr3) To i
            If arr3(i) = arr3(j) And Not i = j Then
                dupBool = True
            End If
        Next j

        If dupBool = False Then
            duparrindex = duparrindex + 1
            ReDim Preserve poArrNoDup(duparrindex)
            poArrNoDup(duparrindex) = arr3(i)
        End If
    Next i

Combine two arrays in one array using vba

arr1 = Range(Range("C13"), Range("C13").End(xlDown)).Value2
arr2 = Range(Range("E13"), Range("E13").End(xlDown)).Value2
'arr2 = ws.Range("E13:E25").Value2
    
arr3 = Split(Join(Application.Transpose(arr1), ",") & "," & Join(Application.Transpose(arr2), ","), ",")
'Debug.Print Join(arr3, ",")

Delete all rows after the current row using vba

 Rows(ActiveCell.Offset(1, 0).Row & ":" & Rows.Count).Delete

Send email in outlook with excel sheet snapshot using VBA

 Option Explicit

Sub Send_Email_With_snapshot()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Sheet1")

Dim lr As Integer
lr = sh.Range("A" & Application.Rows.Count).End(xlUp).Row

sh.Range("A1:H" & lr).Select

With Selection.Parent.MailEnvelope.Item
    .to = sh.Range("L6").Value
    .cc = sh.Range("L7").Value
    .Subject = sh.Range("L8").Value
    .attachments.Add "C:\Users\allso\Desktop\new vba projects\arnab first class.xlsx"
    .send
End With

MsgBox "Done"


End Sub

 

 

 

Source:https://www.pk-anexcelexpert.com/send-email-with-snapshot/

 Source:https://www.youtube.com/watch?v=aD-lo81I5C4

 

Convert excel range to a picture using VBA

 Option Explicit


Sub Exportrangetopicture(oWs As Worksheet, rng As String, num As Integer)
'Hides alerts
 Application.DisplayAlerts = False
 'Dim oWs As Worksheet
 Dim oRng As range
 Dim oChrtO As ChartObject
 Dim lWidth As Long, lHeight As Long

 'Set oWs = sheets("AREA")
 
 Set oRng = oWs.range(rng).CurrentRegion

 oRng.CopyPicture xlScreen, xlPicture
 lWidth = oRng.Width
 lHeight = oRng.Height

 Set oChrtO = oWs.ChartObjects.Add(Left:=0, Top:=0, Width:=lWidth, Height:=lHeight)

 oChrtO.Activate
 With oChrtO.Chart
  .Paste
  .Export Filename:="C:\Users\allso\Desktop\new vba projects\temp" & num & ".jpg", Filtername:="JPG"
 End With

 oChrtO.Delete

 'shows alerts
    Application.DisplayAlerts = True
End Sub

Sub callingfunc()
Workbooks.Open "C:\Users\allso\Desktop\new vba projects\new project subham brother\DPR NOV 2020.xlsb"
Dim ws As Worksheet
Set ws = Workbooks("DPR NOV 2020.xlsb").sheets("AREA")
Call Exportrangetopicture(ws, "J2", 1)
Set ws = Nothing
Set ws = Workbooks("DPR NOV 2020.xlsb").sheets("Zone")
Call Exportrangetopicture(ws, "H1", 2)
Workbooks("DPR NOV 2020.xlsb").Close SaveChanges:=True
End Sub

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

Convert word document to pdf using VBA

Option Explicit

Sub vba_word_to_pdf()

Dim output_file As String

output_file = ActivePresentation.Path & "\" & Left(ActivePresentation.Name, Len(ActivePresentation.Name) - 5) & ".pdf"

'MsgBox ("hello")

ActivePresentation.ExportAsFixedFormat output_file, ppFixedFormatTypePDF, ppFixedFormatIntentPrint

End Sub

Convert all slides in a powerpoint presentation to a pdf using VBA

Option Explicit

Sub vba_powerpoint_to_pdf()

Dim output_file As String

output_file = ActivePresentation.Path & "\" & Left(ActivePresentation.Name, Len(ActivePresentation.Name) - 5) & ".pdf"

'MsgBox ("hello")

ActivePresentation.ExportAsFixedFormat output_file, ppFixedFormatTypePDF, ppFixedFormatIntentPrint

End Sub

Read Pdf without Acrobat

Enable Microsoft Scripting Runtime reference

Option Explicit

Const form_filename As String = "C:\Users\allso\Desktop\New Customer Registration Form.pdf"

Sub read_pdf_form_vals()

Dim fso As New FileSystemObject

Dim tStream As TextStream

Dim vLine As String, vKey As String, fieldlist() As Variant, arrIndx As Integer

Dim i As Integer

vKey = ") Tj"

Set tStream = fso.OpenTextFile(form_filename, ForReading, False)

Do While Not tStream.AtEndOfStream

vLine = tStream.ReadLine

If InStr(vLine, vKey) > 0 Then

vLine = Replace(Right(vLine, Len(vLine) - 1), vKey, "", 1)

ReDim Preserve fieldlist(0 To arrIndx)

fieldlist(arrIndx) = vLine

Debug.Print vLine

arrIndx = arrIndx + 1

End If

'Debug.Print vLine

Loop

For i = UBound(fieldlist) To LBound(fieldlist) Step -1

Debug.Print fieldlist(i)

Next i

Set tStream = Nothing

Set fso = Nothing

End Sub

Determine if an employee should appear using predetermined rules of attendance system

Option Explicit
Sub evenoddconditionalformatting()
'Dim days() As String
Sheets("Sheet1").Select
ActiveSheet.Cells.ClearFormats
'get the days in the days array
Dim selectioncells As Range
Range(Range("B1"), Range("B1").End(xlToRight)).Select

Set selectioncells = selection
 

 'MsgBox (selection.Address)
 'MsgBox (selection.Count)
 Dim arraylength As Integer


 ReDim days(selection.Count)
 'MsgBox (UBound(days))
Dim cell As Range, i As Integer
i = 1
 For Each cell In selectioncells
 days(i) = cell.Value

i = i + 1


 Next
 
 Dim names() As String
 Range("a2", Range("a2").End(xlDown)).Select
 'MsgBox (selection.Count)
 'Dim arraylength As Integer

 Set selectioncells = selection
 ReDim names(selectioncells.Count)
 'MsgBox (UBound(days))
 'Dim cell As Range, i As Integer
 
 For i = 1 To selectioncells.Count
 names(i) = selectioncells(i).Value
 
 
 
 
 Next
'
' For i = 1 To UBound(names)
'
' MsgBox (names(i))
'
' Next i
'
 Dim dict As Object 'Declare a generic Object reference
Set dict = CreateObject("Scripting.Dictionary") 'Late Binding of the Dictionary

For i = 1 To UBound(names)

Dim key, val
key = names(i): val = Application.RandBetween(0, 1)
'Add item to VBA Dictionary
If Not dict.Exists(key) Then
    dict.Add key, val
End If

Next i
'
'Debug.Print dict.Count 'Result: 1
'
For Each key In dict.Keys
   Debug.Print key
Next key
'
''Print all items
'For Each val In dict.Items
'   Debug.Print val
'Next val

Range("L2").Select
For Each key In dict.Keys
   'Debug.Print key
   ActiveCell.Value = key
   ActiveCell.Offset(0, 1).Value = dict(key)
   ActiveCell.Offset(1, 0).Select
  
  
  
Next key

Set selectioncells = Range("B2:H11")
For Each cell In selectioncells
'Debug.Print cell.End(xlToLeft).Value
'Debug.Print cell.End(xlUp).Value




Dim pos As Integer
For i = 1 To UBound(days)
If cell.End(xlUp).Value = days(i) Then
pos = i
Exit For
End If
Next i
'MsgBox (pos)
pos = pos - 1
pos = pos Mod 2
'MsgBox (pos)
Dim pos2 As Integer
For Each key In dict.Keys
   'Debug.Print key
   If cell.End(xlToLeft).Value = key Then
   pos2 = dict(key)
   Exit For
   End If
  
Next key
'MsgBox (pos2)
If pos = pos2 Then
cell.Value = "Should be present"
Else
cell.Value = "Should be absent"
End If

Next cell

ActiveSheet.Columns.AutoFit

Dim mydate As String

mydate = Format(Date, "dddd")

Range(Range("B1"), Range("B1").End(xlToRight)).Select

Set selectioncells = selection
 



 For Each cell In selectioncells
 If mydate = cell.Value Then
 
 Range(cell, cell.End(xlDown)).Select
 

 
 Exit For
 
 End If
 




 Next
Set selectioncells = selection
 

'MsgBox (selectioncells.Address)

 For Each cell In selectioncells
 If cell.Value Like "*present" Then

 cell.Interior.ColorIndex = 44
 Else
 
 





 End If
 

'MsgBox (cell.Value)


 Next

End Sub

Delete single or multiple pages from pdf file automatically using VBA and Acrobat Pro

Option Explicit

Sub deletepagefrompdf()
Dim aapp As Acrobat.AcroApp
Dim todoc As Acrobat.AcroPDDoc

Set aapp = CreateObject("AcroExch.App")
Set todoc = CreateObject("AcroExch.PDDoc")

aapp.Show
todoc.Open ("C:\Users\allso\Desktop\excel_to_pdf\merged_firstpage.pdf")

If todoc.DeletePages(0, 1) = True Then
Debug.Print "Deleted"
Else
Debug.Print "Failed To Delete"
End If


If todoc.Save(PDSaveFull, "C:\Users\allso\Desktop\excel_to_pdf\edited_deleted_firstpage.pdf") = False Then
Debug.Print "Failed to save the file"
Else
Debug.Print "Saved"

End If

todoc.Close

aapp.Exit




Set aapp = Nothing
Set todoc = Nothing

'close the blank acrobat window


Dim sKillExcel As String

sKillExcel = "TASKKILL /F /IM Acrobat.exe"
Shell sKillExcel, vbHide


End Sub

Combine pdfs together automatically using VBA and Acrobat Pro

Option Explicit

Sub combine_pdf_files()

Dim aapp As Acrobat.AcroApp
Dim todoc As Acrobat.AcroPDDoc
Dim fromdoc As Acrobat.AcroPDDoc
Set aapp = CreateObject("AcroExch.App")
Set todoc = CreateObject("AcroExch.PDDoc")
Set fromdoc = CreateObject("AcroExch.PDDOc")
aapp.Show
todoc.Open ("C:\Users\allso\Desktop\blank_pdf.pdf")
fromdoc.Open ("C:\Users\allso\Desktop\201753431466049.pdf")
If todoc.InsertPages(-1, fromdoc, 0, fromdoc.GetNumPages(), True) = False Then
'Here by using -1 we are trying to copy the frompdf to the first
'page of topdf,if the number is 0 it will be the next page from the first,if it is 1 it will be the second page from beginning

Debug.Print "Failed to insert the page"
End If
If todoc.Save(PDSaveFull, "C:\Users\allso\Desktop\excel_to_pdf\merged_firstpage.pdf") = False Then
Debug.Print "Failed to save the file"
Else
Debug.Print "Saved"

End If

todoc.Close
fromdoc.Close
aapp.Exit




Set aapp = Nothing
Set todoc = Nothing
Set fromdoc = Nothing

'closing the blank window of Acrobat

Dim sKillExcel As String

sKillExcel = "TASKKILL /F /IM Acrobat.exe"
Shell sKillExcel, vbHide

End Sub

Kill a running process(In my case it is acrobat) using VBA

Sub test2()
Dim sKillExcel As String

sKillExcel = "TASKKILL /F /IM Acrobat.exe"
Shell sKillExcel, vbHide

End Sub

Source:https://stackoverflow.com/questions/26303173/how-can-i-kill-task-manager-processes-through-vba-code