نحوه اجرای کدهای ماکرو VBA در اکسل
اجرای کد ماکرو VBA در اکسل شامل چند مرحله است. در زیر مراحل اصلی برای ایجاد و اجرای یک ماکرو در اکسل آورده شده است:
۱. فعال‌سازی افزونه Developer
به تب "File" بروید.
گزینه "Options" را انتخاب کنید.
در پنجره "Excel Options"، گزینه "Customize Ribbon" را انتخاب کنید.
تیک "Developer" را بزنید و سپس "OK" کنید.
۲. ایجاد و اجرای ماکرو
در سربرگ اکسل به تب "Developer" بروید.
روی گزینه " Macro" کلیک کنید.
یک نام برای ماکرو انتخاب کنید و روی "Create" کلیک کنید.
توضیحات را وارد کنید (اختیای) و روی "OK" کلیک کنید.
در ماژول باز شده کد رایگان را وارد می کنید و سپس روی "Run" در سربرگ صفحه VBAProject کلیک کنید.
3. ویرایش ماکرو
اگر بخواهید ماکرو را ویرایش کنید:
به تب "Developer" بروید.
روی "Macros" کلیک کنید.
ماکرو موردنظر را انتخاب کنید و روی "Edit" کلیک کنید.
ویرایش‌های لازم را در محیط Visual Basic for Applications (VBA) انجام دهید و سپس فایل را ذخیره کنید.
4. ذخیره‌سازی فایل با ماکرو
برای ذخیره فایل‌هایی که شامل ماکرو هستند:
به تب "File" در سربرگ صفحه اکسل بروید.
روی "Save As" کلیک کنید.
در قسمت "Save as type"، گزینه "Excel Macro-Enabled Workbook (*.xlsm)" را انتخاب کنید و فایل را ذخیره کنید.
فهرست ماکروها
کدهای رایگان ماکرو VBA
ماکروی زیر در شیت Sheet1 ردیفهای مربوط به سلولهای A1 تا A10 که دارای متن Excell هستند را آشکار می‌کند.
Sub UnhideRowsBasedOnText()
Dim ws As Worksheet
Dim cell As Range
Dim targetRange As Range
' Initialize the worksheet object
Set ws = ThisWorkbook.Sheets("Sheet1")
' Define the target range to loop through
Set targetRange = ws.Range("A1:A10")
' Loop through each cell in the target range
For Each cell In targetRange
'Check if the cell value contains the text "Excel"
If cell.Value = "Excel" Then
'Unhide the entire row containing this cell
cell.EntireRow.Hidden = False
End If
Next cell
End Sub
ماکروی بالا طبق توضیحات آن در چهار مرحله تعریف متغیرها، تعریف کاربرگ یا شیت هدف، تعریف رنج
سلولهای هدف در شیت هدف و تعریف گزاره شرطی if در حلقه سلولهای هدف کاربرگ هدف اجرا می‌گردد.
Sub UnmergeAllCells()
Dim ws As Worksheet
' Initialize the worksheet object
Set ws = ThisWorkbook.Sheets("Sheet1")
' Unmerge all merged cells in the worksheet
ws.Cells.UnMerge
End Sub
در این ماکرو ابتدا Sheet1 به عنوان شیت هدف انتخاب و سپس کلیه سلولهای این در صورتی که ادغام هستند، از حالت ادغام خارج می‌شوند.
Sub HighlightMergedCells()
Dim ws As Worksheet
Dim cell As Range
' Set ws as the active worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
' Loop through all cells in the used range of the worksheet
For Each cell In ws.UsedRange
'Check if the cell is merged
If cell.MergeCells Then
'If merged, set the background color to yellow
cell.Interior.Color = RGB(255, 255, 0)
End If
Next cell
End Sub
این ماکرو طبق توضیحات در سه مرحله تعریف متغیرها، تعریف شیت هدف و استفاده از دستور شرطی if
در یک حلقه که بررسی می‌کند آیا سلولها ادغام هستند یا خیر؟ و در صورتی که جواب مثبت باشد،
سلولهای ادغام شده با رنگ قرمز پر می‌شوند اجرا می‌شود.
Sub DeleteBlankRows()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
' Set ws to the active worksheet
Set ws = ActiveSheet
' Find the last row with data in the worksheet
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' Loop from the last row to the first row
For i = lastRow To 1 Step -1
'If the entire row is empty, delete it
If Application.CountA(ws.Rows(i)) = 0 Then
ws.Rows(i).Delete
End If
Next i
End Sub
مراحل زیر در ماکروی بالا بترتیب اجرا می‌شود:
Sub InsertRowAfterEveryOtherRow()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
' Set ws to the active worksheet
Set ws = ActiveSheet
' Find the last row with data in the worksheet
lastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
' Loop from the last row towards the first, moving in steps of 1
For i = lastRow To 1 Step -1
' Insert a new row after each row we visit
ws.Rows(i + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next i
End Sub
این ماکرو طی مراحل زیر اجرا می‌گردد:
Sub HighlightDuplicateValues()
Dim myRange As Range
Dim myCell As Range
' Set myRange to the user's selected range
Set myRange = Selection
' Loop through each cell in the selected range
For Each myCell In myRange
'Use CountIf function to find duplicates within the range
If WorksheetFunction.CountIf(myRange, myCell.Value) > 1 Then
'Highlight the cell with ColorIndex 36 (light green)
myCell.Interior.Color = vbYellow
End If
Next myCell
End Sub
مراحل اجرایی این ماکرو به‌قرار زیر می‌باشد:
Sub ResetAllFilters()
Dim ws As Worksheet
' Loop through each worksheet in the active workbook
For Each ws In ThisWorkbook.Worksheets
' Check if the sheet has autofilters enabled
If ws.AutoFilterMode= True Then
' Clear the autofilters
ws.AutoFilterMode = False
End If
Next ws
End Sub
مراحل ماکرو به‌ترتیب زیر اجرا می‌گردد:
Sub ConvertFormulasToValues()
Dim cell As Range
Dim selectedRange As Range
' Set selectedRange to the user's selected range
Set selectedRange = Selection
' Loop through each cell in the selected range
For Each cell In selectedRange
' Check if the cell has a formula
If cell.HasFormula= True Then
' Replace the formula with its value
cell.Value = cell.Value
End If
Next cell
End Sub
این ماکرو مراحل زیر را اجرا می‌کند:
Sub ExtractURLsFromHyperlinks()
Dim cell As Range
Dim selectedRange As Range
Dim hyperlinkAddress As String
' Set selectedRange to the user's selected range
Set selectedRange = Selection
' Loop through each cell in the selected range
For Each cell In selectedRange
' Check if the cell contains a hyperlink
If cell.Hyperlinks.Count > 0 Then
' Get the URL of the first hyperlink in the cell
hyperlinkAddress = cell.Hyperlinks(1).Address
' Write the URL to the adjacent cell in the next column
cell.Offset(0, 1).Value = hyperlinkAddress
End If
Next cell
End Sub
مراحل اجرایی ماکرو:
Sub FlipDataInColumn()
Dim selectedRange As Range
Dim dataArr() As Variant
Dim i As Long, j As Long
' Set selectedRange to the user's selected range
Set selectedRange = Selection
j = selectedRange.Rows.Count
' Load the data into an array
dataArr = selectedRange.Value
' Loop through the array and swap values to flip the data
For i = 1 To j / 2
temp = dataArr(i, 1)
dataArr(i, 1) = dataArr(j, 1)
dataArr(j, 1) = temp
j = j - 1
Next i
' Write the flipped data back to the column
selectedRange.Value = dataArr
End Sub
ماکروی زیر به‌ترتیب در مراحل زیر اجرا می‌گردد:
