(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)," & """" & """)"
