VBA code for adding progress bar.

Private Sub UserForm_Initialize()

    lblProgressBar.Width = 0

    lblProgressBar.BackColor = RGB(4, 217, 39)

    If Application.International(xlCountryCode) = 49 Then       'German

        ufProgressBar.Caption = "Ihre Anfrage wird bearbeitet..."

    Else

        ufProgressBar.Caption = "Processing Your Request. Please Wait..."

    End If

   

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

    If CloseMode = 0 Then

        Cancel = True

    End If

End Sub

ufProgressBar.Show vbModeless

ufProgressBar.Caption = "Importing data into worksheets " & obj.index & " of " & wb.Sheets.Count

                ufProgressBar.lblProgressBar.Width = CInt((obj.index * 100) / (wb.Sheets.Count)) * ufProgressBar.Width / 100

                ufProgressBar.Repaint

Unload ufProgressBar

How to update chart data range using vba

shtName.ChartObjects("Chart 3").Activate
ActiveChart.SetSourceData Source:=shtAdmin.Range("$A$15:$H" & LR1)

Export workbook .XLSM format to .XLS format.

Sub ExportWorkbook()
    Dim wb As Workbook
    Dim strPunitName As String
    Dim wbName As String

   Application.DisplayAlerts = False
    On Error GoTo Last
    Set wb = ThisWorkbook
    strPunitName = wb.Sheets(home).Range("C20").Value
    wbName = ThisWorkbook.Path & Application.PathSeparator & Trim(strPunitName) & ".xls" '&    Right(ThisWorkbook.Name, Len(ThisWorkbook.Name) - InStr(ThisWorkbook.Name, "."))
    If wbName <> vbNullString Then
    ThisWorkbook.SaveCopyAs FileName:=wbName
    End If
Application.DisplayAlerts = True
Last:
    If Err.Description <> vbNullString Then
    MsgBox Err.Description, vbInformation, title
    End
    End If
End Sub

change label to percentage in bar graph excel using vba macro

Sub set_data_labels_to_bar_chart1()

Dim i As Integer
Dim j As Integer
Dim s As Double
Dim v As Variant

Dim NoDigits As Integer
Dim PercentFormat As String
Dim myTxt As String

NoDigits = 1 'How many digits to round Millions toPercentFormat = "0.0%" 'Format string for the Percentages
With ActiveChart
  For i = 1 To .SeriesCollection.Count
  .SeriesCollection(i).HasDataLabels = True
  Next i
 
  For i = 1 To .SeriesCollection(1).Points.Count
  s = 0
   
  For j = 1 To .SeriesCollection.Count
  v = .SeriesCollection(j).Values
  s = s + v(i)
  Next j
   
  For j = 1 To .SeriesCollection.Count
  v = .SeriesCollection(j).Values
  myTxt = Round(v(i) / 1000000#, NoDigits) & "M, " & Format(v(i) / s, PercentFormat)
  .SeriesCollection(j).Points(i).DataLabel.Text = myTxt
   
  If v(i) <= 0 Then .SeriesCollection(j).Points(i).DataLabel.Delete
  Next j
  Next i
End With
End Sub

Programming helps for a VBA developer.

 (1). Program for selecting a folder using vba.

'******************************************************'

'the dialog is displayed to the user for get a folder  '

'******************************************************'

Public Function GetFolder() As String

With Application.FileDialog(msoFileDialogFolderPicker)

       .InitialFileName = ActiveWorkbook.path & Application.PathSeparator

            .Title = "Select Excel Workbook(s) Folder"

            If .Show = True Then

            GetFolder = .SelectedItems(1)

               Else

            GetFolder = ""

            End If

End With

End Function

(2). A function which can be used for building query dynamically in VBA.

'********************************************'

'Function to build query dynamically.             '

'********************************************'

Function QryLE(Le As String)

If (ThisWorkbook.Worksheets(Menü).Range("E54").Value = "Primary") Then

            QryLE = "SELECT distinct [BuKr]  FROM [KST$]  where [Verantwortl] = '" & Le & "'"

Else

            QryLE = "SELECT distinct [BuKr]  FROM [KST_Sec$]  where [SecondaryCCManager] = '" & Le & "'"

End If

End Function

(3). Program in vba to connect with accss data base.

'*************************************'

'Function for getting all legal entity'

'*************************************'

Function DistinctEntity(Qry As String, Dst As String) As Boolean

Dim cn As ADODB.Connection

Dim rs As ADODB.Recordset

Dim strFile As String

Dim strCon As String

Dim Ls As Integer

Dim cll As String

ThisWorkbook.Worksheets("KST").Rows("1:1").Replace ".", "", LookAt:=xlPart

cll = Left(Dst, 1)

            Set ShtMap = ThisWorkbook.Worksheets("Mapping")

            Set cn = CreateObject("ADODB.Connection")

            Set rs = CreateObject("ADODB.Recordset")

            strFile = ThisWorkbook.FullName

With ShtMap

            Ls = .Cells(.Rows.Count, cll).End(xlUp).Row

End With

            If (Ls <> 1) Then

       ShtMap.Range(cll & "2:" & cll & Ls).ClearContents

            End If

            strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile _

            & ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"

            cn.Open strCon

rs.Open Qry, cn

ShtMap.Range(Dst).CopyFromRecordset rs

DistinctEntity = True

End Function

Program in vba for copy content of one sheet into another sheet.

Sheets(Ende).Copy After:=Workbooks(Dateiname).Sheets(sheetLastcount)

(4). Select a file using file dialog picker in VBA

'***********************************'

'Select a file using folder piker   '

'***********************************'

Public Sub Browse_Click()

Dim myFile As FileDialog

'ErrorHandler

On Error GoTo ErrorHandle

            FileSelected = ""

            Set myFile = Application.FileDialog(msoFileDialogOpen)

            With myFile

       .InitialFileName = ActiveWorkbook.path & Application.PathSeparator

            .Title = "Choose File"

            .Filters.Clear

            .Filters.Add "Excel", "*.xlsx; *.xlsm; *.xlsa", 1

       .AllowMultiSelect = False

            If .Show <> -1 Then

            MsgBox "File not selected", vbInformation

            Exit Sub

            End If

            FileSelected = .SelectedItems(1)

            End With

ErrorHandle:

            If Err Then

            MsgBox "Error" & " : " & Error(Err.Number), vbInformation

            End If

End Sub

(5). Program in vba for checking file is open or not.

'*************************************************'

'Function to check whether file is open or not            '

'*************************************************'

Public Function IsFileOpen(fileName As String)

            Dim filenum As Integer, errnum As Integer

            On Error Resume Next   ' Turn error checking off.

            filenum = FreeFile()   ' Get a free file number.

            ' Attempt to open the file and lock it.

            Open fileName For Input Lock Read As #filenum

            Close filenum              ' Close the file.

            errnum = Err               ' Save the error number that occurred.

            On Error GoTo 0         ' Turn error checking back on.

            ' Check to see which error occurred.

            Select Case errnum

            ' No error occurred.

            ' File is NOT already open by another user.

            Case 0

            IsFileOpen = False

              ' Error number for "Permission Denied."

            ' File is already opened by another user.

            Case 70

            IsFileOpen = True

            ' Another error occurred.

            Case Else

            Error errnum

            End Select

End Function

(6) Program in vba for checking sheet exist or not.

'**************************************

'check if a sheet exists in a workbook

'**************************************

Function sheetExists(wb As String, shtName As String) As Boolean

           

            On Error GoTo ErrHandler

   Workbooks(wb).Activate

            If Workbooks(wb).Sheets(shtName).Visible = xlSheetHidden Or Workbooks(wb).Sheets(shtName).Visible = xlVeryHidden Then

            sheetExists = True

            Else

       Workbooks(wb).Sheets(shtName).Select

            End If

            sheetExists = True

            Exit Function

           

ErrHandler:

            sheetExists = False

            Err.Clear

           

End Function

(7). Program in vba for checking file is open or not.

'******************************************'

'Function for checking file is open or not '

'******************************************'

Function FileOpen() As Boolean

'ErrorHandler

On Error GoTo ErrHandler

If IsFileOpen(FileSelected) Then

            MsgBox "File is already open, Close the source file", vbInformation

            GoTo ErrHandler

End If

            Set wbSource = Workbooks.Open(FileSelected)

            FileOpen = True

            GoTo last

ErrHandler:

FileOpen = False

last:

End Function

(8). Program to declare public constant variable.

Public Const title As String = “Ambarish"

--‘Database connection

Function dbConnection() As Boolean

            Dim conn As New Connection

            Dim rs As New Recordset

            Dim strCon  As String

           

            On Error GoTo Last

            sourcePath = ThisWorkbook.Sheets(shtADMIN).Range("A2").Value

            If sourcePath = "" Then

            MsgBox "Could not establish connection with the database. Please check database path...", vbInformation, "http://programminghelpfordeveloper.blogspot.in/"

       Application.EnableEvents = True

            End

            Else

            strCon = "Provider=Microsoft.ACE.OLEDB.12.0;" & _

            "Data Source=" & sourcePath & _

            ";User Id=admin;Password="

            conn.Open (strCon)

            End If

            If conn.State = adStateClosed Then

            MsgBox "Connection not stablised with database", vbInformation, "http://programminghelpfordeveloper.blogspot.in/"

            End

            Else

            conn.Close

            End If

Last:

            If Err.Description <> "" Then

            MsgBox Err.Description, vbInformation, "http://programminghelpfordeveloper.blogspot.in/"

            End

            End If

End Function

(9). Program to find column no dynamically.

'*******************************************

'Function to find

'*******************************************

Public Function Find_Column(shtName As Worksheet, colName As String) As Long

           

            Dim colNumber

            Dim rng As Range

            On Error GoTo Last

            If Trim(colName) <> vbNullString Then

            With shtName.Range("8:8") 'searches all of column A

            Set rng = .Find(What:=colName, _

                      After:=.Cells(.Cells.Count), _

                      LookIn:=xlValues, _

                      LookAt:=xlWhole, _

                      SearchOrder:=xlByRows, _

                      SearchDirection:=xlNext, _

                      MatchCase:=False)

            If Not rng Is Nothing Then

               Find_Column = rng.Column 'value found

            Else

               Find_Column = 1 'value not found

            End If

            End With

            End If

Last:

            If Err.Description <> vbNullString Then

            MsgBox Err.Description, vbInformation, title

      Application.EnableEvents = True

            End

            End If

End Function

(10). query update insert select delete.

            qry = QueryUpdateTransactionDetailsByRefID1(ws.Cells(obj1.Row, obj1.Column - 2).Value, Szenario, GetPeriodName(Period), obj1.Value, "BUD", "DFT", ThisWorkbook.Worksheets(home).Range("C20").Value, ws.Cells(obj1.Row, obj.Column).Value, GetPeriodName(obj.Value), "CoA_01")

'************************************************************

'Function for building Update query for tblTransactionalData

'************************************************************

Public Function QueryUpdateTransactionDetailsByRefID1(CumulationType As String, senario As String, refPeriod As String, ByVal accountNumber As String, ByVal dataType As String, ByVal transctionType As String, ByVal legalEntity As String, ByVal TransValue As String, ByVal Period As String, ByVal COAID As String) As String

           

            If Trim(CumulationType) = vbNullString Then

            CumulationType = "NULL"

            ElseIf InStr(CumulationType, "'") = 0 Then

            CumulationType = "'" & CumulationType & "'"

            End If

           

            If Trim(senario) = vbNullString Then

            senario = "NULL"

            ElseIf InStr(senario, "'") = 0 Then

            senario = "'" & senario & "'"

            End If

           

            If Trim(refPeriod) = vbNullString Then

            refPeriod = "NULL"

            ElseIf InStr(refPeriod, "'") = 0 Then

            refPeriod = "'" & refPeriod & "'"

            End If

           

            If Trim(accountNumber) = vbNullString Then

            accountNumber = "NULL"

            ElseIf InStr(accountNumber, "'") = 0 Then

            accountNumber = "'" & accountNumber & "'"

            End If

           

            If Trim(TransValue) = vbNullString Then

            TransValue = "NULL"

            ElseIf InStr(TransValue, "'") = 0 Then

            TransValue = "'" & TransValue & "'"

            End If

           

            If Trim(legalEntity) = vbNullString Then

            legalEntity = "NULL"

            ElseIf InStr(legalEntity, "'") = 0 Then

            legalEntity = "'" & legalEntity & "'"

            End If

           

            If Trim(transctionType) = vbNullString Then

            transctionType = "NULL"

            ElseIf InStr(transctionType, "'") = 0 Then

            transctionType = "'" & transctionType & "'"

            End If

           

            If Trim(dataType) = vbNullString Then

            dataType = "NULL"

            ElseIf InStr(dataType, "'") = 0 Then

            dataType = "'" & dataType & "'"

            End If

           

            If Trim(dataType) = vbNullString Then

            dataType = "NULL"

            ElseIf InStr(dataType, "'") = 0 Then

            dataType = "'" & dataType & "'"

            End If

           

            If Trim(transctionType) = vbNullString Then

            transctionType = "NULL"

            ElseIf InStr(transctionType, "'") = 0 Then

            transctionType = "'" & transctionType & "'"

            End If

           

            If Trim(Period) = vbNullString Then

            Period = "NULL"

            ElseIf InStr(Period, "'") = 0 Then

            Period = "'" & Period & "'"

            End If

           

            If Trim(COAID) = vbNullString Then

            COAID = "NULL"

            ElseIf InStr(COAID, "'") = 0 Then

            COAID = "'" & COAID & "'"

            End If

           

   QueryUpdateTransactionDetailsByRefID1 = "Update  tblTransactionalData set AccountID=" & accountNumber & ",[PlanningCycle]=" & refPeriod & ",CumulationType=" & CumulationType & ",Szenario=" & senario & ",[Data Type]=" & dataType & ",[Transaction Type]=" & transctionType & ", [Legal Entity]=" & legalEntity & ", [value]=" & TransValue & ", [Period]=" & Period & ", [COAID] = " & COAID & ",  [Last Updated By]='" & Application.UserName & "' , [Last Updated At]=" & "'" & Now() & "'" & " where AccountID=" & accountNumber & " And [Period]=" & Period & "And [Legal Entity]=" & legalEntity & "And  [Data Type]=" & dataType & "And [Transaction Type]=" & transctionType & "And CumulationType=" & CumulationType

End Function

-------------Insert

            qry = QueryInsertTransactionInDB1(ws.Cells(obj1.Row, obj1.Column - 2).Value, Szenario, GetPeriodName(Period), obj1.Value, "BUD", "DFT", ThisWorkbook.Worksheets(home).Range("C20").Value, ws.Cells(obj1.Row, obj.Column).Value, GetPeriodName(obj.Value), "CoA_01")

'************************************************************

'Function for building Insert query for tblTransactionalData

'************************************************************

Public Function QueryInsertTransactionInDB1(CumulationType As String, senario As String, refPeriod As String, ByVal accountNumber As String, ByVal dataType As String, ByVal transctionType As String, ByVal legalEntity As String, ByVal TransValue As String, ByVal Period As String, ByVal COAID As String) As String

           

            If Trim(CumulationType) = vbNullString Then

            CumulationType = "NULL"

            ElseIf InStr(CumulationType, "'") = 0 Then

            CumulationType = "'" & CumulationType & "'"

            End If

           

            If Trim(senario) = vbNullString Then

            senario = "NULL"

            ElseIf InStr(senario, "'") = 0 Then

            senario = "'" & senario & "'"

            End If

           

            If Trim(refPeriod) = vbNullString Then

            refPeriod = "NULL"

            ElseIf InStr(refPeriod, "'") = 0 Then

            refPeriod = "'" & refPeriod & "'"

            End If

           

            If Trim(accountNumber) = vbNullString Then

            accountNumber = "NULL"

            ElseIf InStr(accountNumber, "'") = 0 Then

            accountNumber = "'" & accountNumber & "'"

            End If

           

            If Trim(dataType) = vbNullString Then

            dataType = "NULL"

            ElseIf InStr(dataType, "'") = 0 Then

            dataType = "'" & dataType & "'"

            End If

           

            If Trim(transctionType) = vbNullString Then

            transctionType = "NULL"

            ElseIf InStr(transctionType, "'") = 0 Then

            transctionType = "'" & transctionType & "'"

            End If

           

            If Trim(legalEntity) = vbNullString Then

            legalEntity = "NULL"

            ElseIf InStr(legalEntity, "'") = 0 Then

            legalEntity = "'" & legalEntity & "'"

            End If

           

            If Trim(TransValue) = vbNullString Then

            TransValue = "NULL"

            ElseIf InStr(TransValue, "'") = 0 Then

            TransValue = "'" & TransValue & "'"

            End If

           

            If Trim(Period) = vbNullString Then

            Period = "NULL"

            ElseIf InStr(Period, "'") = 0 Then

            Period = "'" & Period & "'"

            End If

           

            If Trim(COAID) = vbNullString Then

            COAID = "NULL"

            ElseIf InStr(COAID, "'") = 0 Then

            COAID = "'" & COAID & "'"

            End If

           

   QueryInsertTransactionInDB1 = "Insert into tblTransactionalData ([PlanningCycle],CumulationType,Szenario,AccountID, [Data Type], [Transaction Type], [Legal Entity],[value], [Period], [COAID],  [Last Updated By] , [Last Updated At] ) values (" & Period & "," & CumulationType & "," & senario & "," & accountNumber & ", " & dataType & " ," & transctionType & "," & legalEntity & ", " & TransValue & " , " & refPeriod & ", " & COAID & ", '" & Application.UserName & "','" & Now() & "')"

End Function

--Select

  qry = "SELECT Distinct TextField1 FROM tblPlanning WHERE ([AccountID]=" & "'" & account & "'And [Legal Entity]=" & le & "And Period=" & prd & ")"

(11). Program to convert column no into Alphabet.

'*******************************************************

'This method convert column number in charcter and add $

'*******************************************************

Public Function Col_Letter(lngCol As Long) As String

            Dim vArr As Variant

            On Err GoTo Last

            vArr = Split(Cells(1, lngCol).Address(True, False), "$")

            Col_Letter = vArr(0)

Last:

            If Err.Description <> vbNullString Then

            MsgBox Err.Description, vbInformation, title

      Application.EnableEvents = True

            End

            End If

End Function

(12). How to write description of project.

'.................................................................

'* Author Name :-.

'* Project Name :-                               .

'* Module Name :-                               .

'* Created Date :-                                                     .

'.................................................................

(13). Program to convert German date into English.

'****************************************************

'Function for converting german data to english date'

'****************************************************

Function GetPeriodName(Period As String) As String

            Dim strMnth As String

            Dim strYear As String

           

            strMnth = Format(Period, "MMM")

            strYear = Format(Period, "YYYY")

'           strMnth = Month(Period)

'   strYear = Year(Period)

            Select Case strMnth

            Case "Jan", "1": GetPeriodName = "Jan" & strYear

            Case "Feb", "2": GetPeriodName = "Feb" & strYear

            Case "Mar", "Mrz", "3": GetPeriodName = "Mar" & strYear

            Case "Apr", "4": GetPeriodName = "Apr" & strYear

            Case "May", "Mai", "5": GetPeriodName = "May" & strYear

            Case "Jun", "6": GetPeriodName = "Jun" & strYear

            Case "Jul", "7": GetPeriodName = "Jul" & strYear

            Case "Aug", "8": GetPeriodName = "Aug" & strYear

            Case "Sep", "9": GetPeriodName = "Sep" & strYear

            Case "Oct", "10", "Okt": GetPeriodName = "Oct" & strYear

            Case "Nov", "11": GetPeriodName = "Nov" & strYear

            Case "Dec", "Dez", "12": GetPeriodName = "Dec" & strYear

            Case Else

            GetPeriodName = Period

            End Select

           

End Function

(14). How to use VLOOKUP using worksheets function using vba

Application.WorksheetFunction.VLookup(wsGui.Cells(obj.Row, colAcntNum), rngLookup, 2, False)

(15). How to apply filter using vba.

'***************************************************

'Filter based on selected criteria.

'***************************************************

Sub FilterTo2Criteria(Opt As String, fld As Integer)

LstRwFTE = getLastRow(ThisWorkbook.Worksheets(shtFTE.Name))

With shtFTE

          .AutoFilterMode = False

          .Range("A7:Q" & LstRwFTE).AutoFilter

          .Range("A7:Q" & LstRwFTE).AutoFilter Field:=fld, Criteria1:=Opt, Operator:=xlFilterValues

End With

End Sub

(16). This macro removes any filtering in order to display all of the data but it does not remove the filter arrows

Sub AutoFilter_Remove()

If ActiveSheet.AutoFilterMode Then ActiveSheet.ShowAllData

  ActiveSheet.AutoFilterMode = False

End Sub

(17). Program to fill cell with vlookup function using vba.

‘Vlookup function

"=IFERROR(VLOOKUP($B" & LstRwRpt + 1 & "," & "'Admin-Cost Center Info'!$A$" & 2 & ":$B$" & LstRwDes & "," & 2 & "," & "False)," & """" & """)"