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 Breakdown
- Variable को Declare करना
Dim FilePath As String
Dim FileName As String
Dim FileExtn As String
Dim wb As Workbook - FilePath: वह directory path है जहाँ workbook save की जाएगी।
- FileName: save की गई workbook file का custom नाम रखता है।
- FileExtn: Workbook का file extension store करता है।
- wb: वर्तमान workbook (ThisWorkbook) को refer करता है, जो macro युक्त workbook को represent करता है।
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
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
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
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
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
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
Public Function EmpId()
EmpId = Environ$("UserName")
End Function
Public Function UserName()
UserName = Application.UserName
End Function
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
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
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
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
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
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
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
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
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
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
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
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
Print All queries/connections
Sub DisplayNames()
Dim qry As Variant
For Each qry In ThisWorkbook.Connections
Debug.Print qry.Name
Next qry
End Sub
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
Display Active Workbook Path
Sub ShowWorkbookPath()
MsgBox ActiveWorkbook.FullName
End Sub
Refresh All Data Connections
Save Excel Backup Automatically
Sub AutoBackup()
ActiveWorkbook.SaveCopyAs "C:\Backup\MyBackup_" & Format(Now, "yyyymmdd_hhmm") & ".xlsx"
End Sub
0 टिप्पणियाँ
Please do not enter any spam link in the comment box.