Save Workbook
Introduction
निम्नलिखित दिया गया VBA macro, SaveOutput नामक एक subroutine है जो एक Excel workbook को custom file नाम और extension के साथ एक specific directory में saving को automate करता है। Macro potential errors जैसे कि file path या file नाम missing होने को संभालता है और यह सुनिश्चित करता है कि workbook एक valid स्थान पर save की गई है।
Sub SaveOutput()
Dim FilePath As String
Dim FileName As String
Dim FileExtn As String
Dim wb As Workbook
Set wb = Thisworkbook
FilePath = wb.Sheets(1).Range("A4")
'check if path is blank
If FilePath = "" Then
FilePath = wb.Path
End If
'check if path is incorrect
If Dir(FilePath, vbDirectory) = "" Then
FilePath = wb.Path
End If
'check \ at last of the path
If Right(FilePath, 1) <> "\" Then
FilePath = FilePath & "\"
End If
FileName = wb.Sheets(1).Range("B4")
'check if file name is blank
If FileName = "" Then
FileName = wb.Name & "_" & Format(Date, "ddmmyyyy")
End If
FileExtn = Right(wb.Name, 5)
wb.SaveAs FileName:=FilePath & FileName & FileExtn, AccessMode:=xlShared
End Sub
Code explanation:
यह VBA (Visual Basic for Applications) code Microsoft Excel Workbook को automatic तरीके से save करने के लिए इस्तेमाल किया जाता है। यह code खास तौर पर Dynamic File Path, Auto File Name और Date-based Saving के लिए बहुत उपयोगी है।
SaveOutput नाम का यह Sub सबसे पहले Active Workbook को ThisWorkbook में set करता है। इसके बाद Sheet1 के Cell A4 से File Path और Cell B4 से File Name पढ़ा जाता है। इससे user Excel sheet से ही यह control कर सकता है कि file कहाँ और किस नाम से save होगी।
अगर File Path खाली होता है, तो code अपने आप Workbook के वर्तमान location (wb.Path) को चुन लेता है।
अगर दिया गया Path गलत या मौजूद नहीं होता, तब भी यह code safe तरीके से Workbook के Path पर save करता है।
इसके बाद यह check करता है कि Path के आखिर में Backslash () है या नहीं। अगर नहीं है, तो उसे जोड़ दिया जाता है ताकि SaveAs में कोई error न आए।
File Name के लिए भी validation किया गया है। अगर नाम खाली है, तो यह Workbook Name + Current Date के साथ एक नया नाम बना देता है, जिससे file overwrite होने का risk कम हो जाता है।
अंत में SaveAs command का उपयोग करके Workbook को दिए गए Path, File Name और Extension के साथ save किया जाता है।
AccessMode:=xlShared से यह file share mode में save होती है।
कुल मिलाकर, यह code Excel VBA Automation, Auto Save Logic, Error-Free File Saving और Productivity बढ़ाने के लिए एक simple और प्रभावी समाधान है।
Open File Dialog Box
Public fd As Office.FileDialog
Public strFile As String
Public wb As Workbook
Sub OpenFileDialogBox()
'open the selected file
Application.ScreenUpdating = False
Call OpenRawDataFile
If strFile = "" Then
Exit Sub
Else
Set wb = Workbooks.Open(strFile)
Call MergeData 'change the procedure name to yours
End If
Workbooks(wb.Name).Close
Set wb = Nothing
Application.ScreenUpdating = True
End Sub
Code explanation:
यह VBA (Visual Basic for Applications) code Microsoft Excel में File Dialog Box के माध्यम से file चुनकर उसे open और process करने के लिए बनाया गया है। यह code खास तौर पर Excel Automation, Raw Data Processing और Multiple File Handling में बहुत उपयोगी है।
Code में Office.FileDialog का उपयोग किया गया है, जिससे user को File Open Dialog Box दिखाई देता है। strFile variable में user द्वारा चुनी गई file का पूरा Path save होता है, जबकि wb variable उस file के Workbook को store करता है।
OpenFileDialogBox Sub की शुरुआत में Application.ScreenUpdating = False किया गया है, जिससे code के run होने के दौरान screen flicker नहीं होती और performance बेहतर रहती है।
इसके बाद OpenRawDataFile procedure को call किया जाता है, जो file dialog खोलता है और चुनी गई file का Path strFile में set करता है।
अगर user कोई file select नहीं करता और strFile खाली रहता है, तो code तुरंत Exit हो जाता है।
अगर file select हो जाती है, तो Workbooks.Open(strFile) के जरिए उस Excel file को open किया जाता है। इसके बाद MergeData procedure call होता है, जहाँ चुनी गई file का data process या merge किया जाता है।
data process पूरा होने के बाद file को बिना save किए बंद कर दिया जाता है और memory clean करने के लिए wb = Nothing set किया जाता है।
अंत में ScreenUpdating को फिर से True कर दिया जाता है।
यह code Excel VBA File Picker, Automated Data Merge और User-Friendly File Selection के लिए एक प्रभावी और professional समाधान है।
Sub OpenRawDataFile()
'File open dialog box
Dim uName As String
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Clear
.Filters.Add "Excel Files", "*.xls*", 1
.Filters.Add "Text Files", "*.txt", 2
.Title = "Choose an Excel file"
.AllowMultiSelect = False
'get user name
uName = Environ$("UserName")
If uName = "" Then
uName = Mid(WorksheetFunction.Substitute((Environ$("UserProfile")), "\", "_", 2), WorksheetFunction.Find("_", WorksheetFunction.Substitute((Environ$("UserProfile")), "\", "_", 2)) + 1, 8)
End If
.InitialFileName = "C:\Users\" & uName & "\Downloads"
If .Show = True Then
strFile = .SelectedItems(1)
End If
End With
End Sub
Code explanation:
यह VBA (Visual Basic for Applications) code Microsoft Excel में File Open Dialog Box खोलने के लिए इस्तेमाल किया जाता है, जिससे user आसानी से अपनी ज़रूरत की file चुन सकता है। यह code खास तौर पर Excel File Picker, Raw Data Import और User-Friendly Automation के लिए बहुत उपयोगी है।
OpenRawDataFile नाम का यह Sub Application.FileDialog(msoFileDialogFilePicker) का उपयोग करके File Selection Window खोलता है। इसमें .Filters.Clear के बाद केवल जरूरी file type दिखाए जाते हैं, जैसे **Excel Files (.xls, .xlsx) और Text Files (*.txt)। इससे user को सही file चुनने में आसानी होती है।
Dialog box का title "Choose an Excel file" रखा गया है और .AllowMultiSelect = False से यह सुनिश्चित किया गया है कि user एक समय में सिर्फ एक ही file चुने।
इस code में एक smart logic से Windows User Name निकाला जाता है। Environ$("UserName") से user का नाम लिया जाता है और अगर वह खाली हो, तो UserProfile से backup value निकाली जाती है।
इसके बाद .InitialFileName को user के Downloads Folder पर set किया जाता है, जिससे file जल्दी मिल सके।
जब user file select करता है और OK दबाता है, तो चुनी गई file का पूरा Path strFile variable में save हो जाता है।
कुल मिलाकर, यह code Excel VBA File Dialog, Secure File Selection, और Fast Data Loading के लिए एक simple और असरदार समाधान है, जो automation को ज्यादा professional बनाता है।
Number format for Europe
Sub ThousandFormat()
Dim nFormat As String
If Application.International(xlDecimalSeparator) = "." Then
nFormat = "0.0,""K"""
Else
nFormat = "#,""K""" '"# ""K"""
End If
nFormat = "0" & Application.ThousandsSeparator & "K"
On Error Resume Next
Sheet2.ChartObjects("Chart 3").Activate
ActiveChart.FullSeriesCollection(1).DataLabels.Select
With Selection
.NumberFormat = nFormat
End With
End Sub
Code explanation:
यह VBA (Visual Basic for Applications) code Microsoft Excel Chart के Data Labels को Thousand (K) format में दिखाने के लिए बनाया गया है। यह code खास तौर पर Excel Charts Formatting, Dynamic Number Format और Dashboard Reporting में बहुत उपयोगी है।
ThousandFormat नाम का यह Sub सबसे पहले यह check करता है कि system में Decimal Separator क्या है – dot (.) या comma (,)। यह check Application.International(xlDecimalSeparator) के जरिए किया जाता है, जिससे अलग-अलग regional settings में भी format सही रहे।
इसके बाद code Thousand Separator को ध्यान में रखते हुए एक custom Number Format तैयार करता है।
Application.ThousandsSeparator का उपयोग करके "0K" जैसा format बनाया जाता है, जिससे बड़ी value जैसे 12,500 को 12K के रूप में दिखाया जा सके।
On Error Resume Next का इस्तेमाल किया गया है ताकि अगर chart या data label मौजूद न हों, तो code error दिखाए बिना आगे बढ़ जाए।
इसके बाद Sheet2 में मौजूद Chart 3 को active किया जाता है।
ActiveChart.FullSeriesCollection(1).DataLabels.Select के जरिए पहले data series के data labels को चुना जाता है।
अंत में NumberFormat = nFormat set करके सभी data labels को Thousand (K) format में बदल दिया जाता है।
यह code Excel VBA Chart Automation, Professional Dashboard Design, और Readable Reports बनाने में मदद करता है। इससे chart ज्यादा clean, समझने में आसान और management presentation के लिए perfect बनते हैं।
Sub MillionFormat()
Dim nFormat As String
If Application.International(xlDecimalSeparator) = "." Then
nFormat = "#,##0,,""M"""
Else
nFormat = "#,,""M""" '"# ""M"""
End If
nFormat = "#" & Application.ThousandsSeparator & "##0" & Application.ThousandsSeparator & Application.ThousandsSeparator & """M"""
On Error Resume Next
Sheet2.ChartObjects("Chart 3").Activate
ActiveChart.FullSeriesCollection(1).DataLabels.Select
With Selection
.NumberFormat = nFormat
End With
End Sub
Code explanation:
यह VBA (Visual Basic for Applications) code Microsoft Excel Chart के Data Labels को Million (M) format में दिखाने के लिए बनाया गया है। यह code खास तौर पर Excel Chart Formatting, Million Number Format और Dashboard Visualization में बहुत उपयोगी है।
MillionFormat नाम का यह Sub सबसे पहले system की Regional Settings को ध्यान में रखते हुए Decimal Separator की जाँच करता है। Application.International(xlDecimalSeparator) से यह पता चलता है कि system में dot (.) या comma (,) का उपयोग हो रहा है, जिससे format हर location में सही काम करे।
इसके बाद code Application.ThousandsSeparator का उपयोग करके एक Dynamic Number Format बनाता है। यह format बड़ी संख्याओं को Million में Convert कर देता है, जैसे 2,500,000 को 2.5M या 3M के रूप में दिखाना।
On Error Resume Next का उपयोग इसलिए किया गया है ताकि अगर Chart या Data Labels उपलब्ध न हों, तो VBA code बिना रुके आगे बढ़ सके।
इसके बाद Sheet2 में मौजूद Chart 3 को active किया जाता है और पहले Data Series के Data Labels को select किया जाता है।
अंत में .NumberFormat = nFormat set करके सभी Data Labels को Million (M) format में बदल दिया जाता है।
यह VBA code Excel Dashboard Automation, Clean Data Presentation और Management Reporting के लिए बहुत उपयोगी है। इससे chart ज्यादा professional, clear और पढ़ने में आसान बनते हैं।
Sub UnFormat()
Dim nFormat As String
If Application.International(xlDecimalSeparator) = "." Then
nFormat = "#,##0.0"
Else
nFormat = "0,00" '"0,00"
End If
nFormat = "#" & Application.ThousandsSeparator & "##0"
On Error Resume Next
Sheet2.ChartObjects("Chart 3").Activate
ActiveChart.FullSeriesCollection(1).DataLabels.Select
With Selection
.NumberFormat = nFormat
End With
End Sub
Code explanation:
यह VBA (Visual Basic for Applications) code Microsoft Excel Chart के Data Labels से Thousand (K) या Million (M) format हटाकर उन्हें Normal Number Format में वापस लाने के लिए बनाया गया है। यह code खास तौर पर Excel Chart Unformat, Reset Number Format और Dynamic Dashboard Control के लिए बहुत उपयोगी है।
UnFormat नाम का यह Sub सबसे पहले system की Regional Settings को ध्यान में रखकर Decimal Separator की जाँच करता है। Application.International(xlDecimalSeparator) के जरिए यह पता चलता है कि system में dot (.) या comma (,) का उपयोग हो रहा है, ताकि number format सभी location में सही दिखे।
इसके बाद Application.ThousandsSeparator का उपयोग करके एक Standard Number Format बनाया जाता है, जैसे #,##0। इससे सभी values फिर से पूरी संख्या में दिखाई देती हैं, बिना किसी K या M के।
On Error Resume Next का इस्तेमाल किया गया है ताकि अगर Chart या Data Labels मौजूद न हों, तो code error दिखाए बिना run हो जाए।
इसके बाद Sheet2 में मौजूद Chart 3 को active किया जाता है और पहले Data Series के Data Labels को select किया जाता है।
अंत में .NumberFormat = nFormat set करके Data Labels को उनके Original Numeric Format में वापस बदल दिया जाता है।
यह VBA code Excel Chart Formatting Control, Professional Reporting और Interactive Dashboards के लिए बहुत उपयोगी है। इससे user आसानी से number format बदल और reset कर सकता है।
Display name turns into an email address
Function ResolveDisplayNameToSMTP(sFromName) As String
' takes a Display Name (i.e. "Anand Sagar") and turns it into an email address (anand.sagar@myco.com)
' necessary because the Outlook address is a long, convoluted string when the email is going to someone in the organization.
' source: https://stackoverflow.com/questions/31161726/creating-a-check-names-button-in-excel
Dim olApp As Object 'Outlook.Application
' Dim myNamespace As Outlook.Namespace
' Dim oRecip As Outlook.Recipient
Dim oRecip As Object 'Outlook.Recipient
Dim oEU As Object 'Outlook.ExchangeUser
'Dim oEDL As Object 'Outlook.ExchangeDistributionList
Set olApp = CreateObject("Outlook.Application")
Set oRecip = olApp.Session.CreateRecipient(sFromName)
' Set myNamespace = Application.GetNamespace("MAPI")
' Set oRecip = myNamespace.CreateRecipient(sFromName)
oRecip.Resolve
'Sleep 1000
If Not oRecip.Resolved Then
oRecip.Resolve
End If
If oRecip.Resolved Then
Select Case oRecip.AddressEntry.AddressEntryUserType
Case 0, 5 'olExchangeUserAddressEntry & olExchangeRemoteUserAddressEntry
Set oEU = oRecip.AddressEntry.GetExchangeUser
If Not (oEU Is Nothing) Then
'ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress 'for email
ResolveDisplayNameToSMTP = oEU.Name 'for name
End If
Case 10, 30 'olOutlookContactAddressEntry & 'olSmtpAddressEntry
ResolveDisplayNameToSMTP = oRecip.AddressEntry.Address
End Select
End If
'Sleep 2000
'Set olApp = Nothing
'Set oRecip = Nothing
Set oEU = Nothing
Set oRecip = Nothing
Set olApp = Nothing
End Function
Code explanation:
यह VBA (Visual Basic for Applications) function Microsoft Outlook के Display Name को SMTP Email Address या सही पहचान में बदलने के लिए बनाया गया है। यह code खास तौर पर Excel–Outlook Automation, Email Validation और Corporate Address Book Integration में बहुत उपयोगी है।
ResolveDisplayNameToSMTP नाम का यह Function किसी व्यक्ति का Display Name (जैसे “Anand Sagar”) input के रूप में लेता है और Outlook Address Book की मदद से उसे Resolve करता है। कई बार Outlook में internal email address एक लंबी और जटिल string के रूप में आता है, ऐसे में यह function सही user की पहचान निकालने में मदद करता है।
Code में CreateObject("Outlook.Application") का उपयोग करके Outlook को background में खोला जाता है। इसके बाद CreateRecipient के जरिए दिए गए Display Name से एक Recipient object बनाया जाता है और Resolve method से उसे validated किया जाता है।
अगर Recipient सफलतापूर्वक Resolve हो जाता है, तो AddressEntryUserType के आधार पर यह तय किया जाता है कि वह Exchange User, Remote User, Outlook Contact या SMTP Address है।
Exchange User होने पर GetExchangeUser से उसकी detail निकाली जाती है और ज़रूरत के अनुसार Name या Email Address return किया जाता है।
अंत में सभी Outlook objects को Nothing set किया जाता है, जिससे memory leak न हो।
यह function Auto Email Sending, Name-to-Email Conversion और Outlook VBA Solutions के लिए एक भरोसेमंद और professional तरीका है।
Public Function EmpId()
EmpId = Environ$("UserName")
End Function
Code explanation:
यह VBA (Visual Basic for Applications) function Windows User का Emp ID या User Name निकालने के लिए इस्तेमाल किया जाता है।
EmpId नाम का यह Function Environ$("UserName") का उपयोग करके system में log-in किए हुए user का नाम return करता है।
यह code Excel VBA Automation, User Identification, और Dynamic Reporting में बहुत उपयोगी है।
इससे Excel file अपने आप यह पहचान सकती है कि कौन-सा user report चला रहा है।
इस function का उपयोग Audit Logs, Access Control, Email Automation और SAP / MIS Reports में आसानी से किया जा सकता है।
यह एक Simple, Fast और Secure VBA Solution है, जो बिना किसी manual input के user की जानकारी प्रदान करता है।
Public Function UserName()
UserName = Application.UserName
End Function
Code explanation:
यह VBA (Visual Basic for Applications) function Microsoft Excel में set किया गया User Name प्राप्त करने के लिए उपयोग किया जाता है।
UserName नाम का यह Function Application.UserName का इस्तेमाल करके Excel में दिखने वाला user नाम return करता है।
यह नाम वही होता है जो Excel Options → General में set किया गया होता है, न कि Windows log-in नाम।
यह function Excel Reports, Dashboard Header, Audit Trail और Auto Comments में बहुत उपयोगी है।
इससे report में अपने आप Prepared By / Created By जैसी जानकारी दिखाना आसान हो जाता है।
यह एक Simple और Effective VBA Solution है जो Excel Automation को और ज्यादा professional बनाता है।
Check AutoSave of workbook
Sub ChkAutoSv()
Dim AutoSv As Boolean
If Val(Application.Version) > 15 Then
AutoSv = ActiveWorkbook.AutoSaveOn
'MsgBox "AutoSave set to: " & AutoSv
If AutoSv Then ActiveWorkbook.AutoSaveOn = False
AutoSv = ActiveWorkbook.AutoSaveOn
MsgBox "AutoSave now set to: " & AutoSv
End If
End Sub
Code explanation:
यह VBA (Visual Basic for Applications) code Microsoft Excel में AutoSave feature को check और Disable करने के लिए इस्तेमाल किया जाता है।
ChkAutoSv नाम का यह Sub पहले Excel के Version को check करता है। अगर Version 15 से बड़ा है (Excel 2016 / 365), तब यह code run होता है।
Code ActiveWorkbook.AutoSaveOn के जरिए यह पता लगाता है कि AutoSave ON या OFF है।
अगर AutoSave ON होता है, तो उसे False करके बंद कर दिया जाता है।
अंत में एक Message Box दिखता है, जो user को बताता है कि AutoSave की नई स्थिति क्या है।
यह code Excel VBA Automation, Data Safety और Performance Control के लिए बहुत उपयोगी है।
Get File name from path
Sub GetFilename()
Dim s As String
s = "C:\Users\username\My Documents\abc.txt" 'change path
Dim words() As String
Dim flName As String
words = Split(s, "\")
fldName = words(UBound(words))
Debug.Print "The file name is " & flName
End Sub
Code explanation:
यह VBA (Visual Basic for Applications) code पूरे File Path से सिर्फ File Name निकालने के लिए इस्तेमाल किया जाता है।
GetFilename नाम का यह Sub एक full path string लेता है, जैसे C:\Users\username\My Documents\abc.txt।
Split function की मदद से path को Backslash () के आधार पर अलग-अलग हिस्सों में बाँटा जाता है।
UBound(words) का उपयोग करके आख़िरी हिस्सा लिया जाता है, जो असल में File Name होता है।
इस तरह abc.txt को अलग कर लिया जाता है और Debug.Print से Immediate Window में दिखाया जाता है।
यह code Excel VBA File Handling, Path Processing और Automation Tasks में बहुत उपयोगी है।
Reverse String
Sub ReverseString()
Dim s As String
s = "Apple Orange Pear Mango"
Dim arr() As String
arr = Split(s, " ")
Dim reverseArr() As String
ReDim reverseArr(LBound(arr) To UBound(arr))
Dim i As Long
For i = LBound(arr) To UBound(arr)
reverseArr(UBound(arr) - i) = arr(i)
Next i
Debug.Print "original string: " & s
Debug.Print "new string: " & Join(reverseArr, " ")
End Sub
Code explanation:
यह VBA (Visual Basic for Applications) code String के शब्दों को उल्टे क्रम में बदलने के लिए इस्तेमाल किया जाता है।
ReverseString नाम का यह Sub एक text string लेता है, जैसे "Apple Orange Pear Mango"।
Split function से string को शब्दों की Array में बदला जाता है।
इसके बाद For Loop और UBound का उपयोग करके शब्दों का क्रम उल्टा किया जाता है।
अंत में Join function से नई उलटी string बनाई जाती है और Debug.Print के जरिए दिखायी जाती है।
यह code Excel VBA String Manipulation, Text Processing और Automation Tasks के लिए बहुत उपयोगी है।
Calculate Total Run Time
Sub CalculateTotalRunTime_Minutes()
'PURPOSE: calculate how many total minutes it took for code to completely run
Dim Start_Time As Double
Dim End_Time As String
'Remember time when macro starts
StartTime = Timer
'*****************************
'Insert Your Code Here...
'*****************************
'Determine how many seconds code took to run
End_Time = Format((Timer - StartTime) / 86400, "hh:mm:ss")
'Notify user in seconds
MsgBox "This code ran successfully in " & End_Time & " minutes", vbInformation
End Sub
Code explanation:
यह VBA (Visual Basic for Applications) code Excel Macro के Total Run Time को Minutes में मापने के लिए इस्तेमाल किया जाता है।
CalculateTotalRunTime_Minutes नाम का यह Sub Timer function की मदद से code के शुरू और अंत का समय record करता है।
Macro शुरू होते ही Start Time save किया जाता है।
Code पूरा होने के बाद Timer - StartTime से कुल समय निकाला जाता है और उसे hh:mm:ss format में बदला जाता है।
अंत में MsgBox के जरिए user को बताया जाता है कि Macro कितने समय में पूरा हुआ।
यह code Excel VBA Performance Tracking, Long Macros Optimization और Debugging के लिए बहुत उपयोगी है।
Paste value as value and formula as formula
Sub FormulaPaste()
Dim LastRow As Long
Dim i As Long
LastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If Range("A" & i).Formula = True Then
Range("B" & i) = Range("A" & i)
Else
If Left(Range("A" & i).Formula, 4) = "=SUM" Then
Range("A" & i).Copy Range("B" & i)
Else
Range("B" & i) = Range("A" & i).Formula
End If
End If
Next i
End Sub
Code explanation:
यह VBA (Visual Basic for Applications) code Excel में Formula और Value को सही तरीके से दूसरी column में paste करने के लिए इस्तेमाल किया जाता है।
FormulaPaste नाम का यह Sub column A की आख़िरी Row तक loop चलाता है।
अगर cell में Formula है, तो उसकी value column B में paste की जाती है।
अगर Formula SUM है, तो पूरा Formula copy किया जाता है।
अन्य स्थिति में Formula text के रूप में column B में डाला जाता है।
यह code Excel VBA Formula Handling, Data Processing और Automation Tasks में बहुत उपयोगी है और manual काम कम करता है।
Filter list with multiple criteria in same column
Sub Filter_MultipleValues()
Dim LastRow As Long
Dim FilterArr() As Variant
Dim i As Long
ReDim FilterArr(Sheet47.Range("T1"))
For i = 1 To Sheet47.Range("T1")
FilterArr(i) = Sheet47.Range("U" & i)
Next i
LastRow = Sheet45.Range("BQ20")
If LastRow > 22 Then
Sheet45.Range("BO21:CI" & LastRow).AutoFilter
Sheet45.Range("BO21:CI" & LastRow).AutoFilter Field:=2, Criteria1:=FilterArr, Operator:=xlFilterValues
Sheet45.Range("BX22:BX" & LastRow).SpecialCells(xlCellTypeVisible).ClearContents
Sheet45.Range("BO21:CI" & LastRow).AutoFilter
End If
End Sub
Code explanation:
यह VBA (Visual Basic for Applications) code Excel में Multiple Values के आधार पर AutoFilter लगाने के लिए इस्तेमाल किया जाता है।
Filter_MultipleValues नाम का यह Sub पहले एक Array बनाता है, जिसमें Sheet47 से filter values ली जाती हैं।
इसके बाद Sheet45 में दिए गए data range पर AutoFilter लगाया जाता है।
Criteria1:=FilterArr की मदद से एक साथ कई value पर filter apply होता है।
Filter किए गए data में से केवल Visible Cells को चुनकर उनकी content clear की जाती है।
यह code Excel VBA AutoFilter, Multiple Criteria Filtering और Data Cleaning Automation के लिए बहुत उपयोगी है।
Replace Cell Formula
Sub ReplaceCellFormula()
Dim cel As Range
Dim v1 As String
Dim cv As String
Dim v2 As String
v1 = "=Round("
v2 = ",0)"
For Each cel In Selection
cv = Replace(cel.Formula, "=", "")
cel.Value = v1 & cv & v2
Next
End Sub
Code explanation:
यह VBA (Visual Basic for Applications) code Excel में चुने गए Cells की Formula को Round Formula से Replace करने के लिए इस्तेमाल किया जाता है।
ReplaceCellFormula नाम का यह Sub पहले Selection में मौजूद हर Cell पर loop चलाता है।
Code मौजूदा Formula से = हटाता है और उसे =ROUND(…,0) के अंदर डाल देता है।
इससे सभी Formulas अपने आप 0 Decimal तक Round हो जाती हैं।
यह VBA code Excel Formula Automation, Data Rounding, Financial Reports और Accuracy Control के लिए बहुत उपयोगी है।
इससे manual रूप से Formula बदलने का समय बचता है और काम तेज़ होता है।
Number to Text
'Main Function
Function NumToWords(ByVal MyNumber)
Dim Units As String
Dim SubUnits As String
Dim TempStr As String
Dim DecimalPlace As Integer
Dim Count As Integer
Dim DecimalSeparator As String
Dim UnitName As String
Dim SubUnitName As String
Dim SubUnitSingularName As String
' Change these as required **************************
UnitName = "Rupee" ' NOTE : This is singular
SubUnitName = "Paise" ' NOTE : This is plural
SubUnitSingularName = "Paisa" ' NOTE : This is singular
DecimalSeparator = "."
' ***************************************************
ReDim Place(9) As String
Place(2) = " Thousand "
Place(3) = " Million "
Place(4) = " Billion "
Place(5) = " Trillion "
' Convert MyNumber to STRING and TRIM white space
MyNumber = Trim(CStr(MyNumber))
'If MyNumber is blank then exit
If MyNumber = "" Then
NumToWords = ""
Exit Function
End If
' Find Position of decimal place, 0 if none.
DecimalPlace = InStr(MyNumber, DecimalSeparator)
' Convert SubUnits and set MyNumber to Units amount.
If DecimalPlace > 0 Then
SubUnits = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2))
MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
End If
Count = 1
Do While MyNumber <> ""
TempStr = GetHundreds(Right(MyNumber, 3))
If TempStr <> "" Then Units = TempStr & Place(Count) & Units
If Len(MyNumber) > 3 Then
MyNumber = Left(MyNumber, Len(MyNumber) - 3)
Else
MyNumber = ""
End If
Count = Count + 1
Loop
Select Case Units
Case ""
Units = "No " & UnitName & "s"
Case "One"
Units = "One " & UnitName
Case Else
Units = Units & " " & UnitName & "s"
End Select
Select Case SubUnits
Case ""
SubUnits = " and No " & SubUnitName
Case "One"
SubUnits = " and One " & SubUnitSingularName
Case Else
SubUnits = " and " & SubUnits & " " & SubUnitName
End Select
NumToWords = Application.Trim(Units & SubUnits)
End Function
' Converts a number from 100-999 into text
Function GetHundreds(ByVal MyNumber)
Dim Result As String
If Val(MyNumber) = 0 Then Exit Function
MyNumber = Right("000" & MyNumber, 3)
' Convert the hundreds place.
If Mid(MyNumber, 1, 1) <> "0" Then
Result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred "
End If
' Convert the tens and ones place.
If Mid(MyNumber, 2, 1) <> "0" Then
Result = Result & GetTens(Mid(MyNumber, 2))
Else
Result = Result & GetDigit(Mid(MyNumber, 3))
End If
GetHundreds = Result
End Function
' Converts a number from 10 to 99 into text.
Function GetTens(TensText)
Dim Result As String
Result = "" ' Null out the temporary function value.
If Val(Left(TensText, 1)) = 1 Then ' If value between 10-19...
Select Case Val(TensText)
Case 10: Result = "Ten"
Case 11: Result = "Eleven"
Case 12: Result = "Twelve"
Case 13: Result = "Thirteen"
Case 14: Result = "Fourteen"
Case 15: Result = "Fifteen"
Case 16: Result = "Sixteen"
Case 17: Result = "Seventeen"
Case 18: Result = "Eighteen"
Case 19: Result = "Nineteen"
Case Else
End Select
Else ' If value between 20-99...
Select Case Val(Left(TensText, 1))
Case 2: Result = "Twenty "
Case 3: Result = "Thirty "
Case 4: Result = "Forty "
Case 5: Result = "Fifty "
Case 6: Result = "Sixty "
Case 7: Result = "Seventy "
Case 8: Result = "Eighty "
Case 9: Result = "Ninety "
Case Else
End Select
Result = Result & GetDigit(Right(TensText, 1)) ' Retrieve ones place.
End If
GetTens = Result
End Function
' Converts a number from 1 to 9 into text.
Function GetDigit(Digit)
Select Case Val(Digit)
Case 1: GetDigit = "One"
Case 2: GetDigit = "Two"
Case 3: GetDigit = "Three"
Case 4: GetDigit = "Four"
Case 5: GetDigit = "Five"
Case 6: GetDigit = "Six"
Case 7: GetDigit = "Seven"
Case 8: GetDigit = "Eight"
Case 9: GetDigit = "Nine"
Case Else: GetDigit = ""
End Select
End Function
Code explanation:
यह VBA (Visual Basic for Applications) code Excel में किसी भी नंबर को Words (शब्दों) में बदलने के लिए इस्तेमाल किया जाता है। यह code खास तौर पर Amount in Words, Rupees–Paise Conversion, Invoice और Financial Reports के लिए बहुत उपयोगी है।
NumToWords नाम का यह Function किसी भी Numeric Value को input के रूप में लेता है और उसे Rupee और Paise के रूप में शब्दों में बदल देता है। उदाहरण के लिए 1234.50 को यह “One Thousand Two Hundred Thirty Four Rupees and Fifty Paise” में बदल सकता है।
Code में सबसे पहले Unit Name (Rupee) और Sub Unit Name (Paise / Paisa) को define किया गया है, जिन्हें जरूरत के अनुसार बदला भी जा सकता है। इसके बाद नंबर को String में बदलकर Decimal Separator के आधार पर Rupee और Paise को अलग किया जाता है।
यह Function नंबर को 3-3 अंकों के group में बाँटता है और Thousand, Million, Billion जैसे शब्द अपने आप जोड़ देता है। इसके लिए GetHundreds Function का उपयोग किया गया है, जो 1 से 999 तक की value को Words में बदलता है।
GetTens Function 10 से 99 के बीच के numbers को handle करता है, जिसमें Eleven, Twelve, Twenty, Thirty जैसे शब्द शामिल हैं।
GetDigit Function 1 से 9 तक के numbers को उनके शब्दों में बदल देता है।
Code में Singular और Plural का भी ध्यान रखा गया है, जैसे One Rupee, Two Rupees, One Paisa या Fifty Paise।
अंत में पूरा text साफ-सुथरे format में return किया जाता है।
यह VBA Solution Excel Automation, GST Invoice, Cheque Printing और MIS Reports के लिए बेहद उपयोगी और professional है।
Compile Workbooks with Filter
Sub CompileWorkbookswithFilter()
Dim lastrowstart As Long
Dim lastrowend As Long
Dim KeyDate As String
Application.ScreenUpdating = False
KeyDate = InputBox("enter keydate", "Key date")
Application.DisplayAlerts = False
Path = "C:\Users\username\Desktop\test\" 'path name
Filename = Dir(Path & "*.xlsb")
Do While Filename <> ""
'open each workbook
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
Sheets("Master").Activate 'sheet name
'apply filter
Range("A1:P1").AutoFilter Field:=16, Criteria1:="*" & KeyDate & "*"
Range("A2", Range("A2").End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).SpecialCells(xlCellTypeVisible).Copy
'compile data
ThisWorkbook.Activate
Sheets("Master").Select
lastrowstart = Range("A" & Rows.Count).End(xlUp).Row + 1
Range("A" & lastrowstart).PasteSpecial
Application.CutCopyMode = False
'close file
Workbooks(Filename).Close
Filename = Dir()
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Code explanation:
यह VBA (Visual Basic for Applications) code Multiple Excel Workbooks से Filtered Data को एक Master Workbook में Compile करने के लिए इस्तेमाल किया जाता है। यह code खास तौर पर Excel Data Consolidation, Automation और MIS Reporting में बहुत उपयोगी है।
CompileWorkbookswithFilter नाम का यह Sub सबसे पहले user से Key Date input के रूप में लेता है। यह तारीख बाद में data को filter करने के लिए इस्तेमाल होती है। Performance बेहतर करने के लिए ScreenUpdating और DisplayAlerts को बंद कर दिया जाता है।
Code दिए गए Folder Path में मौजूद सभी .xlsb files को एक-एक करके खोलता है। हर Workbook में Master Sheet को active किया जाता है और Column 16 पर AutoFilter लगाया जाता है, जिसमें वही records चुने जाते हैं जिनमें Key Date मौजूद हो।
Filter होने के बाद सिर्फ Visible Data को copy किया जाता है। फिर यह data वापस इस Macro वाले Workbook की Master Sheet में paste किया जाता है।
LastRow logic की मदद से data हमेशा आख़िरी खाली Row से paste होता है, जिससे पुराना data overwrite नहीं होता।
Data copy हो जाने के बाद हर file को बिना save किए बंद कर दिया जाता है और अगली file पर process चलता रहता है।
यह process तब तक चलता है जब तक folder की सारी files process न हो जाएँ।
अंत में ScreenUpdating और DisplayAlerts को फिर से चालू कर दिया जाता है।
यह VBA code Bulk Excel File Processing, Filter-Based Data Merge और Time Saving Automation के लिए एक प्रभावी समाधान है।
Change shape color
Sub ShapeColor()
If Range("A1") = 1 Then
Sheet1.Shapes("Oval 1").Fill.ForeColor.RGB = RGB(0, 142, 213)
Sheet1.Shapes("Oval 2").Fill.ForeColor.RGB = RGB(8, 14, 23)
Sheet1.Shapes("Oval 1").Line.BackColor.RGB = RGB(0, 0, 0)
Sheet1.Shapes("Oval 2").Line.BackColor.RGB = RGB(0, 0, 0)
End If
End Sub
Code explanation:
यह VBA (Visual Basic for Applications) code Excel में Shapes (जैसे Oval) का रंग Cell Value के आधार पर बदलने के लिए इस्तेमाल किया जाता है।
ShapeColor नाम का यह Sub check करता है कि Cell A1 की value 1 है या नहीं।
अगर condition सही होती है, तो Sheet1 में मौजूद Oval 1 और Oval 2 के Fill Color और Border Color को RGB value से बदल दिया जाता है।
इससे Shape का रंग अपने आप update हो जाता है।
यह code Excel Dashboard, Visual Indicators, Status Display और Interactive Reports के लिए बहुत उपयोगी है।
Cell बदलते ही Shape का रंग बदलना report को ज्यादा professional बनाता है।
Print All queries/connections
Sub DisplayNames()
Dim qry As Variant
For Each qry In ThisWorkbook.Connections
Debug.Print qry.Name
Next qry
End Sub
Code explanation:
यह VBA (Visual Basic for Applications) code Excel Workbook में मौजूद सभी Data Connections के नाम दिखाने के लिए इस्तेमाल किया जाता है।
DisplayNames नाम का यह Sub ThisWorkbook.Connections collection पर loop चलाता है।
हर connection का Name Debug.Print के जरिए Immediate Window में print किया जाता है।
इससे यह आसानी से पता चलता है कि Workbook में कौन-कौन से Power Query, ODBC, SQL या SAP Connections मौजूद हैं।
यह code Excel VBA Debugging, Data Connection Audit और Performance Analysis के लिए बहुत उपयोगी है।
बड़े और जटिल Excel files में यह connection management को आसान बनाता है।
Refresh Query
Sub RefreshQuery()
'ThisWorkbook.Sheets("Summary_Pre").Range("D5").ListObject.TableObject.Refresh
ThisWorkbook.Connections("Query - Pre_Quarter").Refresh
'color the number 6
ActiveSheet.Shapes.Range(Array("Oval 6")).Select
If Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 176, 80) Then
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 112, 192)
Else
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 176, 80)
End If
Range("A2").Select
End Sub
Code explanation:
यह VBA (Visual Basic for Applications) code Excel में Power Query / Data Connection को Refresh करने और Shape का रंग बदलने के लिए इस्तेमाल किया जाता है।
RefreshQuery नाम का यह Sub ThisWorkbook.Connections("Query - Pre_Quarter").Refresh के जरिए दिए गए Query Connection को refresh करता है।
इसके बाद Active Sheet में मौजूद Oval 6 Shape का रंग check किया जाता है।
अगर Shape हरे रंग में है, तो उसे नीला कर दिया जाता है, वरना फिर से हरा कर दिया जाता है।
यह Color Toggle एक Visual Indicator की तरह काम करता है, जिससे पता चलता है कि Query Refresh हो चुकी है।
यह code Excel Dashboard Automation, Data Refresh Status और Interactive Reporting के लिए बहुत उपयोगी है।
Display Active Workbook Path
Sub ShowWorkbookPath()
MsgBox ActiveWorkbook.FullName
End Sub
Code explanation:
यह VBA (Visual Basic for Applications) code Excel में Active Workbook का पूरा Path और File Name दिखाने के लिए इस्तेमाल किया जाता है।
ShowWorkbookPath नाम का यह Sub ActiveWorkbook.FullName का उपयोग करता है, जिससे file का पूरा location (Drive, Folder और File Name) मिलता है।
Code run करते ही एक Message Box में यह जानकारी दिखाई जाती है।
यह feature तब बहुत काम आता है जब एक जैसी नाम की कई files खुली हों या file का सही location जानना हो।
यह code Excel VBA File Location, Debugging और File Management के लिए बहुत उपयोगी है।
Refresh All Data Connections
Sub RefreshData()
ThisWorkbook.RefreshAll
End Sub
Code explanation:
यह VBA (Visual Basic for Applications) code Excel Workbook के सभी Data Connections को एक साथ Refresh करने के लिए इस्तेमाल किया जाता है।
RefreshData नाम का यह Sub ThisWorkbook.RefreshAll command का उपयोग करता है।
इससे Workbook में मौजूद Power Query, Pivot Table, External Data, SQL, SAP या अन्य Connections अपने आप update हो जाते हैं।
User को हर Query या Pivot को अलग-अलग Refresh करने की ज़रूरत नहीं रहती।
यह code Excel Automation, One-Click Data Refresh और Dashboard Update के लिए बहुत उपयोगी है।
बड़े reports और MIS Dashboard में यह समय बचाता है और data को हमेशा latest रखता है।
Save Excel Backup Automatically
Sub AutoBackup()
ActiveWorkbook.SaveCopyAs "C:\Backup\MyBackup_" & Format(Now, "yyyymmdd_hhmm") & ".xlsx"
End Sub
Code explanation:
यह VBA (Visual Basic for Applications) code Excel Workbook का Automatic Backup बनाने के लिए इस्तेमाल किया जाता है।
AutoBackup नाम का यह Sub SaveCopyAs command की मदद से Active Workbook की एक copy अलग location पर save करता है।
File नाम में Current Date और Time जोड़ा जाता है, जैसे MyBackup_20251228_1030.xlsx।
इससे हर backup unique होता है और पुरानी file overwrite नहीं होती।
यह code Excel Data Safety, Auto Backup, Version Control और Risk Prevention के लिए बहुत उपयोगी है।
गलती से data खराब होने पर यह तुरंत recovery में मदद करता है।