User roles in SSRS report server

select  C.UserName, D.RoleName, D.Description, E.Path, E.Name 
from dbo.PolicyUserRole A 
   inner join dbo.Policies B on A.PolicyID = B.PolicyID 
   inner join dbo.Users C on A.UserID = C.UserID 
   inner join dbo.Roles D on A.RoleID = D.RoleID 
   inner join dbo.Catalog E on A.PolicyID = E.PolicyID 
order by C.UserName   

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
 

Transpose Single delimited rows into multiple rows

 

DECLARE @data NVARCHAR(MAX)  
 select  @data= 'Ahamedabad,Bengaluru,Chennai,Delhi'
 DECLARE @sql_xml XML = Cast('<root><U>'+ Replace(@data, ',', '</U><U>')+ '</U></root>' AS XML)
SELECT f.x.value('.', 'VARCHAR(max)') AS Transpose_Values
--INTO #Temp
FROM @sql_xml.nodes('/root/U') f(x)

get names of columns with missing values in ML

 # Fill in the line below: get names of columns with missing values
cols_with_missing = [col for col in X_train.columns
                     if X_train[col].isnull().any()]
# Fill in the lines below: drop columns in training and validation data
reduced_X_train = X_train.drop(cols_with_missing, axis=1)
reduced_X_valid = X_valid.drop(cols_with_missing, axis=1)

Filter your visualization report on passing parameter dynamically on power Bi

In the below screenshot, I am filtering my visualization report based on the selected inputs from the parameter drop down box. click to download the dataset

Please import this dataset on your power bi desktop and follow the instruction below.

• Home->Get Data->Choose Excel->Choose your path->select your excel file
• Click on Home button then Transform data
  
  
  
• Home->Manage Parameter
• 

Note : In type, you can choose any data type based on your requirement. In Suggested values, either you can choose Any value, List of Values or Query. Only the difference is -  in Any value, the input parameter will be constant with the user defined inputs. Inside the List of Values- you can pass multiple parameter but also it would be a constant value or a static parameter. Sometime if you want to modify your parameters you can edit and also data may be differ from your dataset, So the parameter it could not filter your dataset if it is not available.

What if we can add the parameters based on the availability of our data that we have in our Segment field. So, the query option is nothing, it is the set of data that we are creating from our exiting dataset from a particular field.

To create any query on your dataset field , please perform the below step.

Choose you dataset on Edit Query mode-> then Chose your Field->Right Click->Add as new query.

Once the query is created you can choose that Query in query option while creating the parameter.

In this case, the user not to be redefine the parameter values if there are any addons in our dataset.

• select dropdown on your dataset field (Segment on the current data set) and select text filters->Equal 

• Please click on the ABC as per the above screenshot to select parameter.
• Apply and close the power query mode
• Now go to Power BI desktop and transform data
• Edit Parameter
• choose your respective parameter (These parameters are coming from our query that we created on dataset "Segment" field)

• After choosing your parameter value click on apply changes
• and below is my final visualization based on I selected the parameter.

What natural foods should I eat for brain health?

 What natural foods should I eat for brain health?

https://www.quora.com/What-natural-foods-should-I-eat-for-brain-health/answer/Nela-Canovic?ch=99&share=43874a51&srid=TZoV

Breakfast ideas

• Oatmeal. Mix it with 1 tablespoon flaxseeds, 1 teaspoon peanut butter, sliced banana or other fresh fruit, and some walnuts or almonds on top. Flaxseeds are an excellent source of alpha-linolenic acid (ALA), a healthy fat that boosts cerebral cortex function.
• Yogurt and fruit parfait. Layer 1/2 cup of yogurt, 1 tablespoon granola, 1 cup fresh fruit (sliced or diced), and a spoonful of nuts such as walnuts and almonds. Almonds are beneficial for increased attention and awareness necessary for learning, as well as restoring memory and cognitive function.
• An egg or two. Eggs are a powerful mix of B vitamins that help nerve cells burn glucose, antioxidants that protect neurons against damage, and omega-3 fatty acids that keep nerve cells functioning at optimal speed.
• Beet and berry smoothie. Did you know that the natural nitrates in beets can increase blood flow to your brain which improves mental performance? In a blender, combine 1/2 cup of orange juice, 1 cup frozen berries (strawberries, raspberries, blueberries), 1/2 cup diced beets (raw or roasted), 1 tablespoon granola, 2–3 dates, 1/4 cup coconut water or plain low-fat yogurt, and 3 ice cubes. Blend for one minute.

Lunch ideas

• Sardine sandwich. Layer sardines with slices of avocado, then squeeze some lemon juice on top. Sardines are rich in omega-3 fatty acids which are responsible for improving brain cell communication and regulating neurotransmitters that boost mental focus.
• Big salad with fresh spinach and lentils. Lentils are rich in vitamin B which can help improve brain power, while dark leafy greens such as spinach may reduce cognitive decline. For a protein boost that will keep you fuller, add some grilled salmon which is also rich in omega-3 essential fatty acids.

Snack ideas

• Walnuts. This powerful brain food improves cognitive function and can even reduce memory loss. You need less than a handful for maximum effect.
• Fresh fruit. Rich in vitamin C, fruit boosts mental agility and reduces decline in the brain’s cognitive abilities. Eat it whole (apple, banana, tangerine, pear, peach) or dice several different types of fruit and eat as a fruit salad (watermelon, papaya, mango, berries, cantaloupe, oranges, grapefruit, pineapple).
• A fruit and nut mix. This mix of dried fruit and nuts can be prepared ahead of time, it’s portable so you can bring it with you to school or work, and it’s especially good for an energy boost when you feel that mid-afternoon slump.

Dinner ideas

• Seafood. Grill, bake, or saute some salmon, mackerel, kippers, or trout. These are considered oily fish with high levels of omega-3 fatty acids that contribute to healthy brain function and reducing memory loss.
• Tomato and kale salad. Tomatoes are rich in lycopene, an antioxidant that may protect our cells against damage from free radicals which are linked to memory loss. Kale and other dark leafy greens such as chard and spinach is a superfood rich in many vitamins including A, C, and K, and promotes the resilience of brain cells; it can also positively impact our memory, attention, and verbal abilities. Add fresh lemon juice and olive oil to your salad; it’s rich in polyphenols which are found to reduce cognitive decline.
• Sweet potatoes. They are rich in the powerful antioxidant beta carotene, which has been linked to a boost in the brain’s cognitive function. You can steam or boil them much like regular potatoes, or you can cut them into strips and bake in the oven to make sweet potato fries (spice them up with crushed or smoked paprika, pepper, thyme, oregano).
• Whole grains. Rich in complex carbohydrates, fiber, and omega 3 fatty acids, whole grains release glucose slowly into the bloodstream so that your brain gets a steady boost of energy. They can also promote mental alertness and improve your overall mood. Try steaming or preparing them in a rice cooker. Some examples include bulgur, brown rice, barley, whole wheat couscous, and quinoa (which is technically a seed, but is prepared like a grain such as rice).
• Broccoli. It is an excellent source of vitamin K which is responsible for boosting brain power and cognitive function. Steam it for 5-10 minutes just enough for it to soften without losing its rich green color, then drizzle with olive oil and lemon juice, or add a spoonful of plain Greek yogurt or kefir on top for a boost of calcium.
• Legumes. Eat a cupful of garbanzo beans, split peas, or lentils (or combine them). Legumes are rich in folic acid which contributes to a boost in memory and verbal abilities.
• Carrots and squash. Much like sweet potatoes, carrots and all types of squash (spaghetti, acorn, butternut, kabocha) are rich in beta carotene, which helps improve memory and verbal skills. You can eat carrots raw, or you can steam or bake them. Squash is easiest to bake in the oven, either by slicing in half or cutting into large cubes and sprinkling with spices such as oregano, paprika, rosemary, or whatever your own spice preference may be.
• Spices like sage, rosemary or turmeric. Sage has been widely used to improve memory and attention. Rosemary contains carnosic acid which helps to fight free radical damage to the brain, and has been found even to reverse damage to nerve cells. Turmeric contains a powerful compound called curcumin that has anti-inflammatory qualities and may protect the brain against neurological damage; some scientists even claim that it might be effective in treating Alzheimer’s.

Dessert ideas

• Dark chocolate. Cocoa is rich in flavonoids, which are compounds that have been linked to boosting cognitive performance. Have a couple of squares of a good dark chocolate after dinner, instead of a candy bar or doughnut that may have an excess of saturated fats and sugar.