Send an email through outlook including excel graphs/charts

Sub CopyAllChartsToOutlookEmail()
    
     Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xStartMsg As String
    Dim xEndMsg As String
    Dim xChartName As String
    Dim xChartName1 As String
    Dim xChartPath As String
    Dim xChartPath1 As String
    Dim xPath As String
    Dim xPath1 As String
    Dim xChart As ChartObject
    Dim xChart1 As ChartObject
    
    ''----------Copying chart----
    
    On Error Resume Next
    xChartName = "Chart 2"
    xChartName1 = "Chart 3"
    If xChartName = "" And xChartName1 = "" Then Exit Sub
    Set xChart = Sheets("Dashboard").ChartObjects(xChartName)
    Set xChart1 = Sheets("Dashboard").ChartObjects(xChartName1)
    
    
    xChart.Height = 190
    xChart.Width = 200
    
    xChart1.Height = 180
    xChart1.Width = 190
    
    Dim msgdate1 As String
    Dim msgdate2 As String
    Dim msgdate3 As String
    Dim msgdate4 As String
    
    Dim msgdate5 As String

    
'    MsgBox (xChart1)
    If xChart Is Nothing Then Exit Sub
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    xStartMsg = "<font size='3' color='black'>" & dt1 & " | " & Format(dt, "yyyy") & "</font>" & "<font size='5'><br><b>" & "Balance Sheet Account Reconciliation Status " & "</b><br><br></font>"
    xEndMsg = "<font size='4' color='black'><b> Reconciliation Due Dates" & "</b><br></font>"
    
'    msgdate1 = "<font size='3'><b><br>" & "High risk accounts" & "</b></font>" & "<font size='2' color='black'>" & "<ul><li>" & "Reconciliation - " & recDate1 & "</li><li>" & "Review  - " & RevDate1 & "</li></ul></font>"
'    msgdate2 = "<font size='3'><b>" & "Medium risk accounts " & "</b></font>" & "<font size='2' color='black'>" & "<ul><li>" & "Reconciliation - " & recDate1 & "</li><li>" & "Review  - " & RevDate1 & "</li></ul></font>"
'    msgdate3 = "<font size='3'><b>" & "Low risk accounts" & "</b></font>" & "<font size='2' color='black'>" & "<ul><li>" & "Reconciliation - " & recDate1 & "</li><li>" & "Review  - " & RevDate1 & "</li></ul></font>"
    
    msgdate4 = "<font size='5'><b>" & "Reconciliation Completeness | High Risk Accounts " & "</b><br></font>"

    msgdate5 = "<font size='3'><ul><li><b>High risk accounts</b></li><ul><li>" & "Reconciliation - " & recDate1 & "</li><li>" & "Review - " & RevDate1 & "</li></ul><li><b>Medium risk accounts</b><ul><li>" & "Reconciliation - " & recDate1 & "</li><li>" & "Review - " & recDate1 & "</li></ul></li><li><b>Low risk accounts</b><ul><li>" & "Reconciliation - " & recDate1 & "</li><li>" & "Review - " & recDate1 & "</li></ul></li></ul></font>"
    
    xChartPath = ThisWorkbook.Path & "\" & Environ("USERNAME") & VBA.Format(VBA.Now(), "DD_MM_YY_HH_MM_SS") & ".jpg"
    Application.Wait (Now() + TimeValue("00:00:01"))
    xChartPath1 = ThisWorkbook.Path & "\" & Environ("USERNAME") & VBA.Format(VBA.Now(), "DD_MM_YY_HH_MM_SS") & ".jpg"
    xPath = "<p align='Left'><img src=" / "cid:" & Mid(xChartPath, InStrRev(xChartPath, "\") + 1) & """  width=100 height=100 > <br> <br>"
    xPath1 = "<p align='Left'><img src=" / "cid:" & Mid(xChartPath1, InStrRev(xChartPath1, "\") + 1) & """  width=100 height=100 > <br> <br>"
    xChart.Chart.Export xChartPath
    xChart1.Chart.Export xChartPath1
       
    With xOutMail
        .To = "abc@123.com"
        .Subject = "High risk accounts reconciliation | Status " & dt1
        .Attachments.Add Environ("USERPROFILE") & "\Documents\TrinTech_Auto\Detailed Performance PG all units- high risk_not_Completed.xlsx"
        .HTMLBody = xStartMsg & xEndMsg & msgdate5 & msgdate4 & "<img src=" & "'" & xChartPath & "'>" & "<img src=" & "'" & xChartPath1 & "'></html>"
        .Display
'        .Send
    End With
    Kill xChartPath
    Kill xChartPath1
    Set xOutMail = Nothing
    Set xOutApp = Nothing

'     MsgBox ("File is attached and created the email Body with the Dashboard")
    
End Sub

Chart range auto refresh in excel vba

Private Sub Worksheet_activate()
 Dim wS As Worksheet, LastRow As Long
    Set wS = ThisWorkbook.Worksheets("Sheet1")    
    'Here we look in Column F
    LastRow = wS.Cells(wS.Rows.Count, "F").End(xlUp).Row
'LastRow = 5
'    MsgBox (LastRow)
 Dim cht As Chart
    Dim ser As Series
    Dim iSrs As Long, nSrs As Long
    Set cht = ActiveSheet.ChartObjects("Chart 1").Chart
    cht.SetSourceData Source:=Range("F1:" & "S" & LastRow)
End Sub

some trick on VBA

 Post-19 Delete Consecutive row in Excel Macros:

Sub deleteeveryotherrow()
For x = 1 To 100 Step 1
Rows(x & ":" & x).Select
    Selection.Delete Shift:=xlUp
    Next x
End Sub

Post-18 Merge different excel workbooks into a single workbook into different sheets:

Sub MergeExcelFiles()
    Dim fnameList, fnameCurFile As Variant
    Dim countFiles, countSheets As Integer
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook, wbkSrcBook As Workbook 
    fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True) 
    If (vbBoolean <> VarType(fnameList)) Then 
        If (UBound(fnameList) > 0) Then
            countFiles = 0
            countSheets = 0
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
            Set wbkCurBook = ActiveWorkbook
            For Each fnameCurFile In fnameList
            countFiles = countFiles + 1
            Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
            For Each wksCurSheet In wbkSrcBook.Sheets
 countSheets = countSheets + 1
 wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
 Next
   wbkSrcBook.Close SaveChanges:=False
    Next
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
        End If 
    Else
        MsgBox "No files selected", Title:="Merge Excel files"
    End If
End Sub

Post-17 Combine all Sheets into  one Master Sheet in Excel Macros:

Sub Consolidate_Data_From_Different_Sheets_Into_Single_Sheet()
'Procedure to Consolidate all sheets in a workbook
On Error GoTo IfError

'1. Variables declaration
Dim Sht As Worksheet, DstSht As Worksheet
Dim LstRow As Long, LstCol As Long, DstRow As Long
Dim i As Integer, EnRange As String
Dim SrcRng As Range

'2. Disable Screen Updating - stop screen flickering
'   And Disable Events to avoid inturupted dialogs / popups
With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

'3. Delete the Consolidate_Data WorkSheet if it exists
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Sheets("Consolidate_Data").Delete
Application.DisplayAlerts = True

'4. Add a new WorkSheet and name as 'Consolidate_Data'
With ActiveWorkbook
    Set DstSht = .Sheets.Add(After:=.Sheets(.Sheets.Count))
    DstSht.Name = "Consolidate_Data"
End With

'5. Loop through each WorkSheet in the workbook and copy the data to the 'Consolidate_Data' WorkSheet
For Each Sht In ActiveWorkbook.Worksheets
    If Sht.Name <> DstSht.Name Then
       '5.1: Find the last row on the 'Consolidate_Data' sheet
       DstRow = fn_LastRow(DstSht) + 1          
       '5.2: Find Input data range
       LstRow = fn_LastRow(Sht)
       LstCol = fn_LastColumn(Sht)
       EnRange = Sht.Cells(LstRow, LstCol).Address
       Set SrcRng = Sht.Range("A1:" & EnRange)
'5.3: Check whether there are enough rows in the 'Consolidate_Data' Worksheet
        If DstRow + SrcRng.Rows.Count > DstSht.Rows.Count Then
            MsgBox "There are not enough rows to place the data in the Consolidate_Data worksheet."
        GoTo IfError
        End If            
'5.4: Copy data to the 'consolidated_data' WorkSheet
 SrcRng.Copy Destination:=DstSht.Range("A" & DstRow)              
    End If
Next
IfError:

'6. Enable Screen Updating and Events
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

'In this example we are finding the last Row of specified Sheet
Function fn_LastRow(ByVal Sht As Worksheet)
    Dim lastRow As Long
    lastRow = Sht.Cells.SpecialCells(xlLastCell).Row
    lRow = Sht.Cells.SpecialCells(xlLastCell).Row
    Do While Application.CountA(Sht.Rows(lRow)) = 0 And lRow <> 1
        lRow = lRow - 1
    Loop
    fn_LastRow = lRow
End Function

'In this example we are finding the last column of specified Sheet
Function fn_LastColumn(ByVal Sht As Worksheet)
    Dim lastCol As Long
    lastCol = Sht.Cells.SpecialCells(xlLastCell).Column
    lCol = Sht.Cells.SpecialCells(xlLastCell).Column
    Do While Application.CountA(Sht.Columns(lCol)) = 0 And lCol <> 1
        lCol = lCol - 1
    Loop
    fn_LastColumn = lCol
End Function

Post-16 Return First column if Second column has same Values else Second Column in Excel:

=IF(AND(F5=G5,F5=G5),F5,G5)

Post-15 Fill Interior color if it is matched with a particular String:
Private Sub Worksheet_Change(ByVal Target As Range)
    Set MyPlage = Range("B1:B50")
      For Each Cell In MyPlage
              Select Case Cell.Value
                   Case Is = "Withdrawn"
            Cell.EntireRow.Interior.ColorIndex = 7
                  Case Is = "Postponed"
            Cell.EntireRow.Interior.ColorIndex = 8              
        Case Is = "Terms Agreed"
            Cell.EntireRow.Interior.ColorIndex = 4              
        Case Is = "Papers Rec"
            Cell.EntireRow.Interior.ColorIndex = 3              
        Case Else
            Cell.EntireRow.Interior.ColorIndex = xlNone          
        End Select      
    Next
End Sub

Post-15 Update Third column from second if First column has count more than 1:

UPDATE Table1 SET Table1.GTIN3 = GTIN2

WHERE (((Table1.[GTIN]) In (SELECT GTIN

FROM Table1

WHERE GTIN2 is not null and GTIN <> ""

GROUP BY GTIN

HAVING COUNT(*) > 1)));

Post-14 Generate an Excel report on same Project path:
Private Sub Command45_Click()
Dim Range As Object
Dim outputFileName As String
Dim db As DAO.Database
Set db = CurrentDb
outputFileName = CurrentProject.Path & "\Export_" & Format(Date, "yyyy-MM-dd") & ".xls"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "TblMatchedTb", outputFileName, True
End Sub
Post-13 Select string before the last special character:
select Left(dbo_temp_docdesc.DocName,InStrRev(dbo_temp_docdesc.DocName,'.')-1),dbo_temp_docdesc.DocName from dbo_temp_docdesc

Post-12 Convert data type into Number:

For Each c In Range("L2:L2000")

    If c = "" Then GoTo Nextc

    If IsNumeric(c) Then

        c.Value = c.Value * 1

        c.NumberFormat = "general"

    End If

Nextc:

Next c

Post-11 Split rows into distinct rows :

Sub SplitCells()

'Update 20141024

Dim Rng As Range

Dim WorkRng As Range

On Error Resume Next

xTitleId = "KutoolsforExcel"

Set WorkRng = Application.Selection

Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)

For Each Rng In WorkRng

    lLFs = VBA.Len(Rng) - VBA.Len(VBA.Replace(Rng, vbLf, ""))

    If lLFs > 0 Then

        Rng.Offset(1, 0).Resize(lLFs).Insert shift:=xlShiftDown

        Rng.Resize(lLFs + 1).Value = Application.WorksheetFunction.Transpose(VBA.Split(Rng, vbLf))

    End If

Next

End Sub

pass the range like 

Post-10 Selected rows modification and color for it:

Range(ActiveSheet.Range("L2"), ActiveSheet.Range("L2").End(xlDown)).Select

Selection.Interior.ColorIndex = 43

For more about color :
http://dmcritchie.mvps.org/excel/colors.htm

Sub TheWall()
With ActiveSheet.UsedRange.Borders
.LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
 End With
    With ActiveSheet
        .Cells.Font.Size = "10"
        ActiveSheet.Cells.HorizontalAlignment = xlLeft
          End With
        Range("A1:P1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
End Sub

Post-8 A specific Design with Example:-

1. If it is checked on AND button then output should cat and dog

2. If it is checked on OR button then output should cat or dog

3. While click on Category(Sub-Form) it will show like above scenario into down all text boxes.

Following code are usable for it ,paste this code inside the Search button:

Note : Table name is VERSION and sub form name is VERSIONs subform

Step-1

Private Sub Command6_Click()

Dim db As DAO.Database

Dim rs As DAO.Recordset

Set db = CurrentDb()

Dim strFilterSQL As String

Dim strsearch As String

'strsearch = Me.Text0.Value

Dim strSQL As String

If IsNull(Me.Text0) Or Me.Text0 = "" Or Me.Text2 = "" Then

   MsgBox "Please type in your search keyword.", vbOKOnly, "Keyword Needed"

   Me.Text0.BackColor = vbYellow

   Me.Text2.BackColor = vbYellow

   Me.Text0.SetFocus

   Else

'Const strSQL1 = "select code,Category from VERSION"

   Select Case Frame1

    'Filter record source dependant on option checked

        Case 1

        Me.[VERSIONs subform].Form.RecordSource = "select code,Category from VERSIONs Where ([Category]  LIKE '*" & Me.Text0.Value & "*') and ([Category]  LIKE '*" & Me.Text2.Value & "*')"

        Case 2

       Me.[VERSIONs subform].Form.RecordSource = "select code,Category from VERSIONs Where ([Category]  LIKE '*" & Me.Text0.Value & "*') or ([Category]  LIKE '*" & Me.Text2.Value & "*')"

  End Select

    Me.RecordSource = strFilterSQL

    Me.Requery

    Me.Text0.BackColor = vbGreen

    Me.Text2.BackColor = vbGreen

'    Me.[VERSIONs subform].Form.Filter = "[Category]  LIKE '*" & Me.Text0.Value & "*'"

'    Me.[VERSIONs subform].Form.FilterOn = True

'    Me.[VERSIONs subform].Requery

End If

End Sub

paste this code inside the Category on click events

Step-2

Private Sub Category_Click()

Dim rst As DAO.Recordset

   Dim strSQL As String

   Dim seg As String

   Dim segval As String

   Dim Family As String

   Dim Familyval As String

   Dim clas As String

   Dim clasval As String

   Dim comm As String

   Dim commval As String

    '   '===============Segment================

   seg = CStr(Left(Me.Code, 2)) + "000000"

   strSQL = "select Category from VERSIONs where code =" & seg & ""

   Set rst = CurrentDb.OpenRecordset(strSQL)

segval = seg + "   " + rst!Category

   rst.Close

   Set rst = Nothing

Forms![Form1].Text5.Value = segval

   '===============Family======================

    seg = CStr(Left(Me.Code, 4)) + "0000"

    strSQL = "select Category from VERSIONs where code =" & seg & ""

   Set rst = CurrentDb.OpenRecordset(strSQL)

   segval = seg + "   " + rst!Category

   rst.Close

   Set rst = Nothing

 Forms![Form1].Text7.Value = segval

   '==============Class========================

     seg = CStr(Left(Me.Code, 6)) + "00"

   strSQL = "select Category from VERSIONs where code =" & seg & ""

   Set rst = CurrentDb.OpenRecordset(strSQL)

 segval = seg + "   " + rst!Category

   rst.Close

   Set rst = Nothing

Forms![Form1].Text9.Value = segval

   '==============Commedity========================

seg = CStr(Left(Me.Code, 8))

   strSQL = "select Category from VERSIONs where code =" & seg & ""

   Set rst = CurrentDb.OpenRecordset(strSQL)

 segval = seg + "   " + rst!Category

   rst.Close

   Set rst = Nothing

 Forms![Form1].Text11.Value = segval

End Sub

 *********************************************************************************

Post-7 Export Access file to Excel format:-

Private Sub Command45_Click()

Dim Range As Object

Dim outputFileName As String

Dim db As DAO.Database

Set db = CurrentDb

outputFileName = CurrentProject.Path & "\Export_" & Format(Date, "yyyy-MM-dd") & ".xls"

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "TblMatchedTb", outputFileName, True

End Sub

 *********************************************************************************

Post-6 Excel to MS Access converter:-

Private Sub Command0_Click()

Dim strPathFile As String, strFile As String, strPath As String

Dim strTable As String

Dim blnHasFieldNames As Boolean

Const msoFileDialogFilePicker As Long = 3

Dim objDialog As Object

Set objDialog = Application.FileDialog(msoFileDialogFilePicker)

With objDialog

    .AllowMultiSelect = False

    .Show

 If .SelectedItems.Count = 0 Then

        MsgBox "!! No file selected.Please Select One !!"

    Else

    For Each vrtSelectedItem In .SelectedItems

                Filename = vrtSelectedItem

               DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "temp_input", Filename, True

'             objDialog , FileName, blnHasFieldNames

            Next

    End If

End With

End Sub

 *********************************************************************************

Post-5 Function to create auto Number in a table:-
Function CreateAutoNumberField( _

      ByVal strTableName As String, _

      ByVal strFieldName As String) _

      As Boolean

   'References: Microsoft Access 11.0 Object Library, Microsoft DAO 3.6 Object Library

   'Set references by Clicking Tools and Then References in the Code View window

   'Creates an Autonumber field

   'strTableName : Name of table in which to create the field

   'strFieldName : Name of the new field

   'Returns True on success, false otherwise

   'USAGE: CreateAutoNumberField "TABLENAME", "FIELDNAME"

On Error GoTo errhandler

   Dim Db As DAO.Database

   Dim fld As DAO.Field

   Dim tdf As DAO.TableDef

   Set Db = Application.CurrentDb

   Set tdf = Db.TableDefs(strTableName)

' First create a field with datatype = Long Integer

   Set fld = tdf.CreateField(strFieldName, dbLong)

 With fld

      ' Appending dbAutoIncrField to Attributes

      ' tells Jet that it's an Autonumber field

      .Attributes = .Attributes Or dbAutoIncrField

   End With

   With tdf.Fields

      .Append fld

      .Refresh

   End With

   CreateAutoNumberField = True

ExitHere:

   Set fld = Nothing

   Set tdf = Nothing

   Set Db = Nothing

   'MsgBox "Autonumber Complete"

   Exit Function

errhandler:

   CreateAutoNumberField = False

   With Err

      MsgBox "Error " & .Number & vbCrLf & .Description, _

            vbOKOnly Or vbCritical, "CreateAutonumberField"

   End With

   Resume ExitHere

End Function

Note:- after creating this function paste following code into your Button

Private Sub Command0_Click()

Dim Db As DAO.Database

Set Db = CurrentDb()

CreateAutoNumberField "Table1", "GH"

End Sub

 *********************************************************************************
Post-4 Update selected Combo box values in MS Access:-
'update table column and call the module function(removeSpecial)

Private Sub Command24_Click()

Dim db As DAO.Database

Set db = CurrentDb()

'If IsNull(Me.Combo20.Value) Or Me.Combo20.Value = " " Then

db.Execute "update [" + Me.Combo20.Value + "] set mfgid2=removeSpecial([mfgid])"

MsgBox "Table Column Updated"

End Sub
 *********************************************************************************
Post-3 Show all table in mdb into a combobox MS Access:-

Private Sub Command42_Click()
'Set db = CurrentDb()
Dim i As Integer
' ASSIGNING THE COMBO BOX COMBO3 TO NO DISPLAY
Combo20.RowSource = ""
' CLEARING THE COMBO BOX COMBO3
Combo20 = ""
Dim db As DAO.Database, tbl As TableDef, fld As Field
    Set db = CurrentDb()
    For Each tbl In db.TableDefs
    If Left$(tbl.Name, 4) <> "MSys" And Mid(tbl.Name, 2, 4) <> "TMPC" Then
       Combo20.AddItem tbl.Name
    End If
    Next tbl
End Sub
Note - If you want to refresh list after creating new table then paste this code again into new Command button.
 *********************************************************************************
Post-2. MS - Access Functions:-
'Function for Revome SpeclChar
 Function removeSpecial(sInput As String) As String
    Dim sSpecialChars As String
    Dim i As Long
    sSpecialChars = "-&\/:*?""<>|@#"
    For i = 1 To Len(sSpecialChars)
        sInput = Replace$(sInput, Mid$(sSpecialChars, i, 1), "")
    Next
    removeSpecial = sInput
End Function
 *********************************************************************************
'Function for calculating Variance of Two Columns in a Table
Function VarianceCalculate(sInput1 As Integer, sInput2 As Integer)
VarianceCalculate = ((sInput1 - sInput2) / sInput1 * 100)
If (VarianceCalculate) < 1 Then
VarianceCalculate = ((sInput2 - sInput1) / sInput2 * 100)
End If
End Function
 *********************************************************************************
'Function to Delete a Table if allready Exist
Function TableExists(ByVal TableName As String) As Boolean
'*************************************************
' Purpose: Checks to see whether the named table exists in the database
'
' Returns: True, if table found in current db, False if not found.
'************************************************* ****************************
Dim strTableNameCheck
On Error GoTo ErrorCode
'try to assign tablename value
strTableNameCheck = CurrentDb.TableDefs(TableName)
'If no error and we get to this line, true
TableExists = True
ExitCode:
On Error Resume Next
Exit Function
ErrorCode:
Select Case Err.Number
Case 3265 'Item not found in this collection
TableExists = False
Resume ExitCode
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "hlfUtils.TableExists"
'Debug.Print "Error " & Err.number & ": " & Err.Description & "hlfUtils.TableExists"
Resume ExitCode
End Select
End Function
*********************************************************************************

Post-1. Excel Macros:-

Delete First Rows in Single Sheet:

Sub sbVBS_To_Delete_EntireRow()

Rows(1).EntireRow.Delete

End Sub

---------------------

Delete First Rows for all sheets

Sub LoopThroughSheets()

    Dim ws As Worksheet

    For Each ws In ActiveWorkbook.Worksheets

    ws.Range("1:1").Delete

    Next ws

End Sub

---------------------

Add Sheet Name in First column - in all Sheets 

Sub Prepare_Sheet()

    Dim WS As Worksheet

    Dim LASTROW As Long

    For Each WS In Sheets

        With WS

            LASTROW = .Range("A" & Rows.Count).End(xlUp).Row

            .Columns(1).Insert

            .Range("A1:A" & LASTROW) = WS.Name

        End With

    Next WS

End Sub

---------------------

add column Name

Sub Prepare_Sheet()

 Dim WS As Worksheet

    Dim LASTROW As Long

    For Each WS In Sheets

        With WS        

        .Range("A1") = "SheetName"

        

'            LASTROW = .Range("A" & Rows.Count).End(xlUp).Row

'            .Columns(1).Insert

'            .Range("A1:A" & LASTROW) = WS.Name

        End With

    Next WS

End Sub
---------------------

import to one sheet:
Sub CombineSheets()

   Dim ws As Worksheet, wsCombine As Worksheet

   Dim rg As Range

   Dim RowCombine As Integer

   Set wsCombine = ThisWorkbook.Worksheets.Add(ThisWorkbook.Worksheets(1))

   wsCombine.Name = "Combine"

   RowCombine = 1

   For Each ws In ThisWorkbook.Worksheets

      If ws.Index <> 1 Then

         Set rg = ws.Cells(1, 1).CurrentRegion

         rg.Copy wsCombine.Cells(RowCombine, 2)

         wsCombine.Range(Cells(RowCombine, 1), Cells(RowCombine + rg.Rows.Count - 1, 1)).NumberFormat = "@"

         wsCombine.Range(Cells(RowCombine, 1), Cells(RowCombine + rg.Rows.Count - 1, 1)) = ws.Name

         RowCombine = RowCombine + rg.Rows.Count

      End If

   Next

   wsCombine.Cells(1, 1).EntireColumn.AutoFit

   Set rg = Nothing

   Set wsCombine = Nothing

End Sub

=============

Delete Empty Columns

Sub DeleteBlankColumns()

'Step1:  Declare your variables.

    Dim MyRange As Range

    Dim iCounter As Long

'Step 2:  Define the target Range.

    Set MyRange = ActiveSheet.UsedRange    

'Step 3:  Start reverse looping through the range.

    For iCounter = MyRange.Columns.Count To 1 Step -1    

'Step 4: If entire column is empty then delete it.

       If Application.CountA(Columns(iCounter).EntireColumn) = 0 Then

       Columns(iCounter).Delete

       End If

'Step 5: Increment the counter down

    Next iCounter    

        Columns("C:C").Select

    Selection.Delete Shift:=xlToLeft

    Columns("H:H").Select

    Selection.Delete Shift:=xlToLeft    

End Sub

=============

insert new column
Sub InsertColumns()

'PURPOSE: Insert column(s) into the active worksheet

'SOURCE: www.TheSpreadsheetGuru.com

'Insert Column to the left of Column D

    Columns("D:D").Insert Shift:=xlToRight, _

      CopyOrigin:=xlFormatFromLeftOrAbove 'or xlFormatFromRightOrBelow

'Insert 2 Columns to the left of Column G

    Columns("G:H").Insert Shift:=xlToRight, _

      CopyOrigin:=xlFormatFromLeftOrAbove 'or xlFormatFromRightOrBelow

End Sub

===============

Select only filled row in excel (diagonally)
Sub Select_UsedRange()

  ActiveSheet.UsedRange.Select

End Sub

===============

merge all excel sheet into one

Sub simpleXlsMerger()

Dim bookList As Workbook

Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object

Application.ScreenUpdating = False

Set mergeObj = CreateObject("Scripting.FileSystemObject")

'change folder path of excel files here

Set dirObj = mergeObj.Getfolder("D:\change\to\excel\files\path\here")

Set filesObj = dirObj.Files

For Each everyObj In filesObj

Set bookList = Workbooks.Open(everyObj)

'change "A2" with cell reference of start point for every files here

'for example "B3:IV" to merge all files start from columns B and rows 3 

'If you're files using more than IV column, change it to the latest column

'Also change "A" column on "A65536" to the same column as start point

Range("A2:IV" & Range("A65536").End(xlUp).Row).Copy

ThisWorkbook.Worksheets(1).Activate

'Do not change the following column. It's not the same column as above

Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial

Application.CutCopyMode = False

bookList.Close

Next

End Sub
===============

copy file name
Sub GetFileNames()     

    Dim xRow As Long

    Dim xDirect$, xFname$, InitialFoldr$     

    InitialFoldr$ = "C:\Users\mso\Desktop\2016 Periop Inventory Final_Done" '<<< Startup folder to begin searching from     

    With Application.FileDialog(msoFileDialogFolderPicker)

        .InitialFileName = Application.DefaultFilePath & "\"

        .Title = "Please select a folder to list Files from"

        .InitialFileName = InitialFoldr$

        .Show

        If .SelectedItems.Count <> 0 Then

            xDirect$ = .SelectedItems(1) & "\"

            xFname$ = Dir(xDirect$, 7)

            Do While xFname$ <> ""

                ActiveCell.Offset(xRow) = xFname$

                xRow = xRow + 1

                xFname$ = Dir

            Loop

        End If

    End With

End Sub

Removing blank series from an excel chart

Dim chtob As ChartObject
  Dim seriesLine As Series
'''---removing blank series
  Set chtob = ActiveSheet.ChartObjects("Chart 2")
  For Each seriesLine In chtob.Chart.SeriesCollection
    seriesLine.IsFiltered = (seriesLine.Name = "")
  Next seriesLine  

Excel Macro to color and formatting different series charts and labels

Private Sub Worksheet_activate()
    Dim cht As Chart
    Dim ser As Series
    
    Dim iSrs As Long, nSrs As Long   
    Set cht = ActiveSheet.ChartObjects("Chart 4").Chart    
    
With cht
    nSrs = .SeriesCollection.Count
    Dim srsName As String
    
     For iSrs = 1 To nSrs
     srsName = (.SeriesCollection(iSrs).Name)
    
Select Case iSrs    
    Case 1
    Set ser = cht.SeriesCollection(iSrs)
    ser.Format.Line.Visible = msoFalse
    ser.Format.Line.Visible = msoTrue
    ser.Format.Line.ForeColor.RGB = RGB(255, 0, 0)
    ser.DataLabels.Font.Color = RGB(255, 0, 0)
    
Case 2
    Set ser = cht.SeriesCollection(iSrs)
    ser.Format.Line.Visible = msoFalse
    ser.Format.Line.Visible = msoTrue
    ser.Format.Line.ForeColor.RGB = RGB(0, 28, 93)
    ser.DataLabels.Font.Color = RGB(0, 28, 93)
    
Case 3
    Set ser = cht.SeriesCollection(iSrs)
    ser.Format.Line.Visible = msoFalse
    ser.Format.Line.Visible = msoTrue
    ser.Format.Line.ForeColor.RGB = RGB(162, 162, 162)
    ser.DataLabels.Font.Color = RGB(162, 162, 162)
    
Case 4
    Set ser = cht.SeriesCollection(iSrs)
    ser.Format.Line.Visible = msoFalse
    ser.Format.Line.Visible = msoTrue
    ser.Format.Line.ForeColor.RGB = RGB(255, 191, 0)
    ser.DataLabels.Font.Color = RGB(255, 191, 0)
    
Case 5
    Set ser = cht.SeriesCollection(iSrs)
    ser.Format.Line.Visible = msoFalse
    ser.Format.Line.Visible = msoTrue
    ser.Format.Line.ForeColor.RGB = RGB(177, 208, 235)
    ser.DataLabels.Font.Color = RGB(177, 208, 235)
    
Case 6
    Set ser = cht.SeriesCollection(iSrs)
    ser.Format.Line.Visible = msoFalse
    ser.Format.Line.Visible = msoTrue
    ser.Format.Line.ForeColor.RGB = RGB(109, 171, 67)
    ser.DataLabels.Font.Color = RGB(109, 171, 67)
    
Case 7
    Set ser = cht.SeriesCollection(iSrs)
    ser.Format.Line.Visible = msoFalse
    ser.Format.Line.Visible = msoTrue
    ser.Format.Line.ForeColor.RGB = RGB(212, 17, 167)
    ser.DataLabels.Font.Color = RGB(212, 17, 167)
End Select
 Next
End With
End Sub
 

Serial number in all sheets excel macros

Sub Serial_number()
On Error Resume Next

Dim tot_Sheets As Integer
tot_Sheets = Application.Sheets.Count
Dim s As Integer
For s = 1 To tot_Sheets
'Sheets(ActiveSheet.Index + 1).Activate
If s <> 0 Then Sheets(s).Activate
'----------------serial number on sheets----------------
'Check last row_number for a filled cell in sheets
Dim colName As String
colName = "A"
Dim LastCell As Integer
LastCell = Sheets(s).Range(colName & ":" & colName).SpecialCells(xlCellTypeLastCell).Row
'insert a new column to assign serial number
Sheets(s).Columns("A:A").Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromLeftOrAbove
'----------------------
'assigning serial number
Dim j As Integer
Dim i As Integer
j = LastCell
For i = 1 To j
Sheets(s).Range("A" & i + 1).Value = i
Next i
Dim c As Integer
Sheets(s).Range("A" & i).Delete
'-----------------------
Next s
End Sub

Add a consecutive serial number into multiple sheets in a single excel file

The below code will help you to create a breaking serial numbers into multiple sheets in an excel macros. Suppose we have a number of four sheets into an excel workbook and each sheets containg few records. The scenario from below code will assign an unique numbers to all four sheets where the number is ending to the last record.

On above scenario sheet1 is having 6 records and assgnig with 1-6 serial number. Similarly for all sheet2,sheet3,sheet4 creating an unique number where the number is ending into the last sheet.

Note : This code is valid upto 4 sheets.

Sub AddSerialNumbers()
On Error GoTo Last
Dim colName As String
'----------------serial numb1r on sheet1----------------
'Check last row_number for a filled cell in sheet1
colName = "A"
Dim LastCell As Integer
LastCell = Sheet1.Range(colName & ":" & colName).SpecialCells(xlCellTypeLastCell).Row

'insert a new column to assign serial number
Sheet1.Columns("A:A").Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromLeftOrAbove

'assigning serial number
Dim j As Integer
Dim i As Integer
j = LastCell
For i = 1 To j
Sheet1.Range("A" & i + 1).Value = i
Next i
Dim c As Integer
Sheet1.Range("A" & i).Delete
'----------------serial number on sheet2----------------
'Check last row_number for a filled cell in sheet2
Dim LastCell2 As Integer
LastCell2 = Sheet2.Range(colName & ":" & colName).SpecialCells(xlCellTypeLastCell).Row

'insert a new column to assign serial number
Sheet2.Columns("A:A").Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromLeftOrAbove

'assigning serial number
Dim j1 As Integer
Dim i1 As Integer
j1 = LastCell2
For i1 = 1 To j1
Sheet2.Range("A" & i1 + 1).Value = i - 2 + i1
Next i1
Dim t As Integer
t = i - 2 + i1
Sheet2.Range("A" & i1).Delete
'----------------serial number on sheet3----------------
'Check last row_number for a filled cell in sheet3
Dim LastCell3 As Integer
LastCell3 = Sheet3.Range(colName & ":" & colName).SpecialCells(xlCellTypeLastCell).Row

'insert a new column to assign serial number
Sheet3.Columns("A:A").Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromLeftOrAbove

'assigning serial number
Dim j2 As Integer
Dim i2 As Integer
j2 = LastCell3
For i2 = 1 To j2
Sheet3.Range("A" & i2 + 1).Value = t - 2 + i2
Next i2
Dim t1 As Integer
t1 = i2 - 2 + t
Sheet3.Range("A" & i2).Delete
'----------------serial number on sheet4----------------
'Check last row_number for a filled cell in sheet4
Dim LastCell4 As Integer
LastCell4 = Sheet4.Range(colName & ":" & colName).SpecialCells(xlCellTypeLastCell).Row

 'insert a new column to assign serial number
Sheet4.Columns("A:A").Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromLeftOrAbove

'assigning serial number
Dim j3 As Integer
Dim i3 As Integer
j3 = LastCell4
For i3 = 1 To j3
Sheet4.Range("A" & i3 + 1).Value = t1 - 2 + i3
Next i3
Sheet4.Range("A" & i3).Delete
Last:
End Sub

Combine all Sheets into one Master Sheet in Excel Macros

Sub Consolidate_Data_From_Different_Sheets_Into_Single_Sheet()
'Procedure to Consolidate all sheets in a workbook
On Error GoTo IfError

'1. Variables declaration
Dim Sht As Worksheet, DstSht As Worksheet
Dim LstRow As Long, LstCol As Long, DstRow As Long
Dim i As Integer, EnRange As String
Dim SrcRng As Range

'2. Disable Screen Updating - stop screen flickering
'   And Disable Events to avoid inturupted dialogs / popups
With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

'3. Delete the Consolidate_Data WorkSheet if it exists
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Sheets("Consolidate_Data").Delete
Application.DisplayAlerts = True

'4. Add a new WorkSheet and name as 'Consolidate_Data'
With ActiveWorkbook
    Set DstSht = .Sheets.Add(After:=.Sheets(.Sheets.Count))
    DstSht.Name = "Consolidate_Data"
End With

'5. Loop through each WorkSheet in the workbook and copy the data to the 'Consolidate_Data' WorkSheet
For Each Sht In ActiveWorkbook.Worksheets
    If Sht.Name <> DstSht.Name Then
       '5.1: Find the last row on the 'Consolidate_Data' sheet
       DstRow = fn_LastRow(DstSht) + 1          
       '5.2: Find Input data range
       LstRow = fn_LastRow(Sht)
       LstCol = fn_LastColumn(Sht)
       EnRange = Sht.Cells(LstRow, LstCol).Address
       Set SrcRng = Sht.Range("A1:" & EnRange)
'5.3: Check whether there are enough rows in the 'Consolidate_Data' Worksheet
        If DstRow + SrcRng.Rows.Count > DstSht.Rows.Count Then
            MsgBox "There are not enough rows to place the data in the Consolidate_Data worksheet."
        GoTo IfError
        End If            
'5.4: Copy data to the 'consolidated_data' WorkSheet
 SrcRng.Copy Destination:=DstSht.Range("A" & DstRow)              
    End If
Next
IfError:

'6. Enable Screen Updating and Events
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

'In this example we are finding the last Row of specified Sheet
Function fn_LastRow(ByVal Sht As Worksheet)
    Dim lastRow As Long
    lastRow = Sht.Cells.SpecialCells(xlLastCell).Row
    lRow = Sht.Cells.SpecialCells(xlLastCell).Row
    Do While Application.CountA(Sht.Rows(lRow)) = 0 And lRow <> 1
        lRow = lRow - 1
    Loop
    fn_LastRow = lRow
End Function

'In this example we are finding the last column of specified Sheet
Function fn_LastColumn(ByVal Sht As Worksheet)
    Dim lastCol As Long
    lastCol = Sht.Cells.SpecialCells(xlLastCell).Column
    lCol = Sht.Cells.SpecialCells(xlLastCell).Column
    Do While Application.CountA(Sht.Columns(lCol)) = 0 And lCol <> 1
        lCol = lCol - 1
    Loop
    fn_LastColumn = lCol
End Function

Merge different excel workbooks into a single workbook into different sheets

Sub MergeExcelFiles()
    Dim fnameList, fnameCurFile As Variant
    Dim countFiles, countSheets As Integer
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook, wbkSrcBook As Workbook 
    fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True) 
    If (vbBoolean <> VarType(fnameList)) Then 
        If (UBound(fnameList) > 0) Then
            countFiles = 0
            countSheets = 0
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
            Set wbkCurBook = ActiveWorkbook
            For Each fnameCurFile In fnameList
            countFiles = countFiles + 1
            Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
            For Each wksCurSheet In wbkSrcBook.Sheets
 countSheets = countSheets + 1
 wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
 Next
   wbkSrcBook.Close SaveChanges:=False
    Next
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
        End If 
    Else
        MsgBox "No files selected", Title:="Merge Excel files"
    End If
End Sub

Delete Consecutive row in Excel Macros

Sub deleteeveryotherrow()
For x = 1 To 100 Step 1
Rows(x & ":" & x).Select
    Selection.Delete Shift:=xlUp
    Next x
End Sub

How to open an excel sheet through a MS Access Button and do it modification.

Dim db As DAO.Database
Set db = CurrentDb()
      
Dim FileNameBase As String
FileNameBase = CurrentProject.path & "\YourExcelSheetName ".xlsx"
Dim strFileName As String
strFileName = Replace(FileNameBase, "[CurrentDate]", Format$(Date, "m-dd-yyyy"))

'---Exporting from Ms Access table to an Excel worksheet
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "TableName1", strFileName, True, "Sheet_One_Name_You_Want"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "TableName2", strFileName, True, "Sheet_Two_Name_You_Want"

'--------------Open that excel sheet and here you do all modification-----------------------------------
 Dim appExcel1 As Excel.Application
    Dim wbk1 As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim rng As Excel.Range
    
    Set appExcel1 = Excel.Application
    appExcel1.Visible = True
    Set wbk1 = appExcel1.Workbooks.Open(strFileName)
    
    appExcel1.ScreenUpdating = False
 ' -----------------------------------Formatting Sheet_One_Name_You_Want Sheet -------------------
     Sheets("Sheet_One_Name_You_Want").Select
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Columns.AutoFit
    Range(Selection, Selection.End(xlToRight)).Columns.AutoFit
    Range(Selection, Selection.End(xlDown)).HorizontalAlignment = xlLeft
    Range(Selection, Selection.End(xlToRight)).HorizontalAlignment = xlLeft

    Range("A1:AK1").RowHeight = 30
    Range("A1:AK1").ColumnWidth = 15
    Range("A1:AK1").Font.Bold = True
    Range("A1:AK1").WrapText = True
    Range("A1:AK1").VerticalAlignment = Excel.Constants.xlCenter

'---------------Coloring-----------------
Range("A1:B1").Select
Selection.Interior.ColorIndex = 33

Range("C1").Select
Selection.Interior.ColorIndex = 27
Range("D1").Select
Selection.Interior.ColorIndex = 45

'--------------Change Data type to Currency Format for a Particular column--------------
Range("F2:F100").Select
Selection.Style = "Currency"
'------------------FreezePanes for a Particular column--------------
Range("C1").Select
wbk1.Application.ActiveWindow.FreezePanes = True
END Sub

Border Line for a filled cell in Excel VBA.

Once a time I was trying to create a report on excel through MS ACCESS vba. At that time I was really wanted to keep the border for all filled cells. I got a user define function from a browsing web page and it was really helpful.  You can modify this function according to your requirement.

Sub TheBorderLine()

With ActiveSheet.UsedRange.Borders

        .LineStyle =xlContinuous

        .Weight = xlThin

        .ColorIndex = xlAutomatic

 End With

    With ActiveSheet

        .Cells.Font.Size ="10"  

ActiveSheet.Cells.HorizontalAlignment = xlLeft

          End With

        Range("A1:S1").Select

    With Selection

        .HorizontalAlignment = xlCenter

        .VerticalAlignment = xlCenter

    End With

  End Sub

Execution Process :
Call this function inside your button just like a - call TheBorderLine or just put TheBorderLine.
Make sure that your workbook is open while calling this function.

Delete rows from a sheet with an equal number of Intervals in Excel Macros

Sub deleteeveryotherrow()
For x = 3 To 100 Step 1
 Rows(x & ":" & x).Select
    Selection.Delete Shift:=xlUp
 Rows(x & ":" & x).Select
    Selection.Delete Shift:=xlUp
    x = x + 1
    Next x
End Sub