HERE ARE SOME USEFUL CODE FOR YOU

Golden Web Tools · VBA Suite Pro

Golden Web Tools

EXCEL VBA · PROFESSIONAL SUITE

Auto Adjust R/C

' AutoFit Columns & Rows Columns("A:F").AutoFit Rows("2:10").AutoFit ' Entire sheet auto adjust Cells.EntireColumn.AutoFit Cells.EntireRow.AutoFit
Ready

Data Entry Form

' VBA UserForm with TextBox, ComboBox Dim lastRow As Long lastRow = Range("A" & Rows.Count).End(xlUp).Row + 1 Range("A" & lastRow).Value = txtName.Text Range("B" & lastRow).Value = txtDept.Text Range("C" & lastRow).Value = txtAmount.Text Range("D" & lastRow).Value = cmbCategory.Value
Ready · auto cell adjust

Auto Serial #

' Auto Serial Number in Column A Range("A2").Value = 1 Range("A3").Value = 2 ' Or loop Dim i As Long For i = 2 To 100 Range("A" & i).Value = i - 1 Next i
1,2,3,...10 (simulated)

PDF Export

' Export ActiveSheet as PDF ActiveSheet.ExportAsFixedFormat _ Type:=xlTypePDF, _ Filename:="Report_" & Format(Date, "yyyymmdd") & ".pdf", _ Quality:=xlQualityStandard
Click to export

Email (Outlook)

' Send Email via Outlook Dim OutApp As Object, OutMail As Object Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) With OutMail .To = "user@domain.com" .Subject = "Report" .Body = "Please find attached." .Attachments.Add ActiveWorkbook.FullName .Send End With
Ready

Backup Workbook

' Auto Backup Workbook ActiveWorkbook.SaveCopyAs _ "Backup_" & Format(Now, "yyyymmdd_hhmmss") & ".xlsm" ' Also auto-save original ActiveWorkbook.Save
Click to backup

Search Data

' Search for value in Column A Dim found As Range Set found = Range("A:A").Find(What:="John", LookAt:=xlPart) If Not found Is Nothing Then MsgBox "Found at " & found.Address Else MsgBox "Not found" End If
Enter term & search

Attendance System

' Mark Attendance with Timestamp Dim lastRow As Long lastRow = Range("A" & Rows.Count).End(xlUp).Row + 1 Range("A" & lastRow).Value = Range("B1").Value ' Name Range("B" & lastRow).Value = "Present" Range("C" & lastRow).Value = Now ' Format timestamp Range("C" & lastRow).NumberFormat = "dd-mmm-yyyy hh:mm:ss"
Ready

Digital Watch

' VBA: Live Clock with OnTime Sub UpdateClock() Range("A1").Value = Format(Now, "hh:mm:ss") Application.OnTime Now + TimeValue("00:00:01"), "UpdateClock" End Sub ' Call UpdateClock to start
00:00:00

₹ Rupee Converter

' Convert Number to Indian Rupees (Text) Function IndianRupee(amt As Double) As String Dim crore, lakh, thousand, remainder ' Custom logic for Crore, Lakh, Thousand ' Returns "Rupees ... Only" End Function
Rupees ...

Remove Duplicates

' Remove duplicates based on Column A Range("A1").CurrentRegion.RemoveDuplicates _ Columns:=1, Header:=xlYes ' Or entire row unique ActiveSheet.UsedRange.RemoveDuplicates _ Columns:=Array(1, 2), Header:=xlYes
Ready

Freeze / Split

' Freeze top row and first column With ActiveWindow .SplitColumn = 1 .SplitRow = 1 .FreezePanes = True End With ' Or freeze first row only Rows("2:2").Select ActiveWindow.FreezePanes = True
Choose freeze option

Sort & Filter

' Sort by column B descending, then filter Range("A1:D100").Sort _ Key1:=Range("B1"), Order1:=xlDescending, Header:=xlYes ' Apply AutoFilter Range("A1").AutoFilter Field:=1, Criteria1:=">1000" ' Clear filter ActiveSheet.AutoFilterMode = False
Sort / filter simulated

Delete Empty Rows

' Delete all blank rows in used range Dim rng As Range Set rng = ActiveSheet.UsedRange rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete ' Or loop backwards Dim i As Long For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1 If Application.WorksheetFunction.CountA(Rows(i)) = 0 Then Rows(i).Delete Next i
Click to delete blank rows

Workbook Events

' ThisWorkbook module Private Sub Workbook_Open() MsgBox "Welcome! File opened at " & Now ' Auto refresh or run macro End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) If MsgBox("Save before closing?", vbYesNo) = vbYes Then ThisWorkbook.Save End Sub
Event not triggered
Golden Web Tools · Professional VBA Suite · Click to copy any code
Next Post Previous Post
No Comment
Add Comment
comment url