فهرست ماکروهای رایگان VBA در اکسل
قبل از توضیح ماکروها نحوه اجرای کدهای ماکرو VBA در اکسل را به صورت گام به گام ارائه می دهیم:
اجرای کد ماکرو VBA در اکسل شامل چند مرحله است. در زیر مراحل اصلی برای ایجاد و اجرای یک ماکرو در اکسل آورده شده است:
۱. فعال‌سازی افزونه Developer
۲. ایجاد و اجرای ماکرو
3. ویرایش ماکرو
اگر بخواهید ماکرو را ویرایش کنید:
4. ذخیره‌سازی فایل با ماکرو
برای ذخیره فایل‌هایی که شامل ماکرو هستند:
لازم به ذکر است در کلیه متن کلمات Workbook، Worksheet، Sheet به ترتیب با کلمات کتاب کار، کاربرگ و برگه معادل سازی شد.
1-سلول های خالی را با صفر جایگزین کنید
Sub ReplaceBlanksWithZeros()
Dim ws As Worksheet
Dim selectedRange As Range
Dim cell As Range
' Set a reference to the active worksheet and selected range
Set ws = ActiveSheet
Set selectedRange = Selection
' Loop through each cell in the selected range
For Each cell In selectedRange
' If the cell is empty, set its value to zero
If IsEmpty(cell.Value) Then
cell.Value = 0
End If
Next cell
End Sub
از طریق هر سلول در محدوده انتخاب شده حلقه می زند تا خالی بودن آن را بررسی کند. اگر سلولی خالی باشد، کد مقدار آن را صفر می کند.
2-سلول های خالی را با NA یا هر متن دیگری جایگزین کنید
Sub ReplaceBlanksWithNA()
Dim ws As Worksheet
Dim selectedRange As Range
Dim cell As Range
Dim replaceText As String
' Set the text you want to replace blank cells with
replaceText = "NA"
' Set a reference to the active worksheet and selected range
Set ws = ActiveSheet
Set selectedRange = Selection
' Loop through each cell in the selected range
For Each cell In selectedRange
' If the cell is empty, set its value to "NA"
If IsEmpty(cell.Value) Then
cell.Value = replaceText
End If
Next cell
End Sub
3-ورق ها را بر اساس حروف الفبا مرتب کنید
Sub SortSheetsAlphabetically()
Dim i As Integer, j As Integer
Dim ws1 As Worksheet, ws2 As Worksheet
' Loop through each worksheet to sort them
For i = 1 To ThisWorkbook.Sheets.Count
For j = i + 1 To ThisWorkbook.Sheets.Count
' Set references to the worksheets to be compared
Set ws1 = ThisWorkbook.Sheets(i)
Set ws2 = ThisWorkbook.Sheets(j)
' Compare worksheet names and swap if necessary
If ws1.Name > ws2.Name Then
ws2.Move Before:=ws1
End If
Next j
Next i
End Sub
4-از همه برگه ها محافظت کنید
Sub ProtectAllSheets()
Dim ws As Worksheet
Dim pwd As String
' Set the password
pwd = "password123"
' Loop through each worksheet in the workbook
For Each ws In ThisWorkbook.Sheets
' Protect the worksheet with the password
ws.Protect Password:=pwd
Next ws
End Sub
Sub ProtectAllSheetsNoPassword()
Dim ws As Worksheet
' Loop through each worksheet in the workbook
For Each ws In ThisWorkbook.Sheets
' Protect the worksheet without a password
ws.Protect
Next ws
End Sub
5-لغو محافظت از همه برگه ها
Sub UnprotectAllSheets()
Dim ws As Worksheet
' Loop through each worksheet in the workbook
For Each ws In ThisWorkbook.Sheets
' Unprotect the worksheet
ws.Unprotect
Next ws
End Sub
6-نمایش همه کاربرگ های پنهان
Sub UnhideAllSheets()
Dim ws As Worksheet
' Loop through each worksheet in the workbook
For Each ws In ThisWorkbook.Sheets
' Unhide the worksheet if it is hidden
If ws.Visible = xlSheetHidden Or ws.Visible = xlSheetVeryHidden Then
ws.Visible = xlSheetVisible
End If
Next ws
End Sub
7-همه را به جز کاربرگ فعال حذف کنید
Sub DeleteAllButActive()
Dim ws As Worksheet
' Disable alerts to prevent confirmation boxes from appearing
Application.DisplayAlerts = False
' Loop through each worksheet in the workbook
For Each ws In ThisWorkbook.Sheets
' If the worksheet is not the active sheet, delete it
If ws.Name <> ActiveSheet.Name Then
ws.Delete
End If
Next ws
' Enable alerts
Application.DisplayAlerts = True
End Sub
8-درج چند کاربرگ
Sub InsertMultipleWorksheets()
Dim I As Integer
Dim ws As Worksheet
‘ Number of sheets to insert
Dim numSheets As Integer
numSheets = 5
‘ Loop to insert multiple sheets
For I = 1 To numSheets
‘ Insert new worksheet at the end
Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
Next i
End Sub
9-حذف همه کاربرگ های خالی (حذف برگه های خالی)
Sub DeleteBlankSheetsUsingCOUNTA()
Dim ws As Worksheet
Dim nonEmptyCells As Long
' Disable alerts to prevent confirmation boxes from appearing
Application.DisplayAlerts = False
' Loop through each worksheet in the workbook
For Each ws In ThisWorkbook.Sheets
' Count non-empty cells in the worksheet using COUNTA function
nonEmptyCells = Application.WorksheetFunction.CountA(ws.Cells)
' Delete the worksheet if COUNTA returns 0, meaning it's empty
If nonEmptyCells = 0 Then
ws.Delete
End If
Next ws
' Enable alerts
Application.DisplayAlerts = True
End Sub
10-ارسال Active Sheet در ایمیل
Sub SendActiveSheetInEmail()
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim tempFilePath As String
' Create a new Outlook application
Set OutlookApp = CreateObject("Outlook.Application")
' Create a new email item
Set OutlookMail = OutlookApp.CreateItem(0)
' Save the active sheet to a temporary location
tempFilePath = Environ("temp") & "\" & ActiveSheet.Name & ".xlsx"
ActiveSheet.Copy
ActiveWorkbook.SaveAs Filename:=tempFilePath
ActiveWorkbook.Close SaveChanges:=False
' Configure and send email
With OutlookMail
.To = "Excel@stevespreadsheetplanet.com" ' Modify this line
.Subject = "Latest Data Attached" ' Modify this line
.Body = "Please find the attached the Latest Data." ' Modify this line
.Attachments.Add tempFilePath ' Attach the temporary file
.Send
End With
' Delete the temporary file
Kill tempFilePath
' Release the Outlook objects
Set OutlookMail = Nothing
Set OutlookApp = Nothing
End Sub
11-تغییر رنگ برگه برگه
Sub ChangeSheetTabColors()
Dim ws As Worksheet
Dim newColor As Long
' Define the new color (RGB value of Green)
newColor = RGB(255, 0, 0)
' Loop through each worksheet in the active workbook
For Each ws In ThisWorkbook.Sheets
' Change the tab color
ws.Tab.Color = newColor
Next ws
End Sub
با استفاده از مقدار RGB ، 255، 0، 0 رنگ برگه جدید را سبز تعریف می کند.
برای هر کاربرگ، رنگ برگه را به رنگ جدید تعریف شده (که در این مثال کد قرمز است) تغییر می دهد.
12- کاربرگ ها را به عنوان فایل های CSV ذخیره کنید
Sub ExportWorksheetsAsCSV()
Dim ws As Worksheet
Dim folderPath As String
Dim csvFilePath As String
' Get the folder path of the active workbook
folderPath = ThisWorkbook.Path
' Loop through each worksheet in the active workbook
For Each ws In ThisWorkbook.Sheets
' Generate the full path for the new CSV file
csvFilePath = folderPath & "\" & ws.Name & ".csv"
' Export the worksheet to a CSV file
ws.Copy
ActiveWorkbook.SaveAs Filename:=csvFilePath, FileFormat:=xlCSV
ActiveWorkbook.Close SaveChanges:=False
Next ws
End Sub
13- پشتیبان گیری از کتاب کار فعلی با مهر زمان
Sub BackupWorkbookWithTimestamp()
Dim filePath As String
Dim fileName As String
Dim timeStamp As String
' Create a timestamp in the format "yyyyMMdd_hhmmss"
timeStamp = Format(Now, "yyyyMMdd_hhmmss")
' Get the current workbook's path and name
filePath = ThisWorkbook.Path
fileName = ThisWorkbook.Name
' Create the new name for the backup file by appending the timestamp
Dim backupFileName As String
backupFileName = Replace(fileName, ".xlsx", "_" & timeStamp & ".xlsx")
' Generate the full path for the backup file
Dim backupFilePath As String
backupFilePath = filePath & "\" & backupFileName
' Save a backup copy of the current workbook
ThisWorkbook.SaveCopyAs backupFilePath
End Sub
14-برگه فعال را در یک کتاب کار جدید کپی کنید
Sub CopyActiveSheetToNewWorkbook()
Dim newWb As Workbook
Dim ws As Worksheet
' Reference the active worksheet
Set ws = ActiveSheet
' Create a new workbook
Set newWb = Workbooks.Add
' Copy the active sheet to the new workbook
ws.Copy Before:=newWb.Sheets(1)
' Delete the default sheet created when the new workbook was made
Application.DisplayAlerts = False
newWb.Sheets(2).Delete
Application.DisplayAlerts = True
End Sub
15-ارسال Active Workbook در ایمیل
Sub SendActiveWorkbookInEmail()
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim wb As Workbook
' Reference to the active workbook
Set wb = ThisWorkbook
' Create a new Outlook application
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
' Save the workbook to ensure changes are sent
wb.Save
' Configure and send the email
With OutlookMail
.To = "recipient@example.com" ' Replace with the recipient's email
.CC = ""
.BCC = ""
.Subject = "Here is the workbook"
.Body = "Please find attached the workbook."
.Attachments.Add wb.FullName
.Display ' Use .Send to send the email automatically
End With
' Release resources
Set OutlookMail = Nothing
Set OutlookApp = Nothing
End Sub
16-نمایش پیام خوش آمدگویی در باز کردن کتاب کار
Private Sub Workbook_Open()
' Display a welcome message box
MsgBox "You're Awsome", vbInformation, "Welcome"
End Sub
نکته مهم : از آنجایی که این یک کد رویداد است، به این معنی که هنگام وقوع یک رویداد اجرا می‌شود (مانند باز کردن یک کتاب کار)، باید این کد را در پنجره کد شی ThisWorkbook جای‌گذاری کنید. برای این کار روی ThisWorkbook در قسمت Properties دوبار کلیک کنید و سپس این کد را در پنجره کد باز شده قرار دهید.
17-همه کتاب کارهای اکسل باز را می‌بندد (به جز کتاب کار فعال)
Sub CloseAllWorkbooksExceptActive()
Dim wb As Workbook
Dim activeWb As Workbook
' Store a reference to the active workbook
Set activeWb = ActiveWorkbook
' Loop through each open workbook
For Each wb In Application.Workbooks
' If the workbook is not the active one, close it
If Not wb Is activeWb Then
wb.Close SaveChanges:=False ' Change to True if you want to save changes
End If
Next wb
End Sub
18-ویژگی های Text Wrap را حذف کنید
Sub RemoveTextWrapFromSheet()
Dim ws As Worksheet
' Reference to the active worksheet
Set ws = ActiveSheet
' Remove text wrap from all cells in the worksheet
ws.Cells.WrapText = False
End Sub
19-پاک کردن محتوا از شیت
Sub ClearSheetContent()
Dim ws As Worksheet
‘ Reference to the active worksheet
Set ws = ActiveSheet
‘ Clear content from all cells in the worksheet
ws.Cells.ClearContents
End Sub
20-اعداد منفی را برجسته کنید
Sub HighlightNegativeNumbers()
Dim ws As Worksheet
Dim condFormat As FormatCondition
' Reference to the active worksheet
Set ws = ActiveSheet
' Clear any existing conditional formatting
ws.Cells.FormatConditions.Delete
' Add new conditional formatting rule to highlight negative numbers
Set condFormat = ws.Cells.FormatConditions.Add(Type:=xlCellValue, Operator:=xlLess, Formula1:="0")
' Set the formatting options for negative numbers
With condFormat.Interior
.ColorIndex = 3 ' Red
End With
End Sub
در زیر کدی وجود دارد که از قالب بندی شرطی استفاده نمی کند:
Sub HighlightNegativeNumbersNoCondFormat()
Dim ws As Worksheet
Dim cell As Range
' Set a reference to the active worksheet
Set ws = ActiveSheet
' Loop through each cell in the used range of the worksheet
For Each cell In ws.UsedRange.Cells
' Check if the cell value is negative
If cell.Value < 0 Then
' Highlight the cell in red (ColorIndex 3)
cell.Interior.ColorIndex = 3
End If
Next cell
End Sub
21-سلول ها را با نظرات برجسته کنید
Sub HighlightCellsWithComments()
Dim ws As Worksheet
Dim cell As Range
' Reference to the active worksheet
Set ws = ActiveSheet
' Loop through each cell in the used range
For Each cell In ws.UsedRange
' Check if the cell has a comment
If Not cell.Comment Is Nothing Then
' Highlight the cell in yellow (ColorIndex 6)
cell.Interior.ColorIndex = 6
End If
Next cell
End Sub
اگر نظری وجود داشته باشد، سلول با رنگ زرد برجسته می شود.
22-سطرهای جایگزین را در قسمت انتخاب برجسته کنید
Sub HighlightAlternateRowsInSelection()
Dim cell As Range
Dim i As Long
' Initialize the row counter
i = 0
' Loop through each cell in the first column of the selection
For Each cell In Selection.Columns(1).Cells
' Increment the row counter
i = i + 1
' Check if the row is odd or even
If i Mod 2 = 0 Then
' Highlight the entire row within the selection in light blue (ColorIndex 34)
cell.EntireRow.Interior.ColorIndex = 6
End If
Next cell
End Sub
23-سلول های با کلمات غلط املایی را برجسته کنید
Sub HighlightMisspelledCells()
Dim rng As Range ' Declare a variable to hold each cell in the UsedRange
' Loop through each cell in the UsedRange of the active sheet
For Each rng In ActiveSheet.UsedRange
' Use the Application.CheckSpelling function to check the spelling of the cell's text
If Not Application.CheckSpelling(word:=rng.Text) Then
' If the word is misspelled, apply the "Bad" style to the cell
rng.Interior.ColorIndex = 6
End If
Next rng
End Sub
24- سلول‌های با یک متن خاص در کاربرگ را مشخص کنید
Sub HighlightErrorCells()
Dim ws As Worksheet
Dim cell As Range
' Reference to the active worksheet
Set ws = ActiveSheet
' Loop through each cell in the used range of the worksheet
For Each cell In ws.UsedRange
' Check if the cell contains an error
If IsError(cell.Value) Then
' Highlight the cell in red (ColorIndex 3)
cell.Interior.ColorIndex = 3
End If
Next cell
End Sub
25- حداکثر مقدار را در یک یا چند ستون مشخص کنید
Sub HighlightMaxValue()
Dim cell As Range
Dim maxVal As Double
‘ Use Excel’s MAX function to find the maximum value in the selected range
maxVal = Application.WorksheetFunction.Max(Selection)
‘ Loop through each cell in the selected range to highlight the maximum value
For Each cell In Selection
If cell.Value = maxVal Then
cell.Interior.ColorIndex = 6 ‘ Highlight with yellow color
End If
Next cell
End Sub
در صورتی که انتخاب شما شامل چندین ستون است و می خواهید حداکثر مقدار را در هر ستون برجسته کنید، می توانید از کد زیر استفاده کنید:
Sub HighlightMaxValueInEachColumn()
Dim cell As Range
Dim col As Range
Dim maxVal As Double
‘ Loop through each column in the selected range
For Each col In Selection.Columns
‘ Use Excel’s MAX function to find the maximum value in the current column
maxVal = Application.WorksheetFunction.Max(col)
‘ Loop through each cell in the current column to highlight the maximum value
For Each cell In col.Cells
If cell.Value = maxVal Then
cell.Interior.ColorIndex = 6 ‘ Highlight with yellow color
End If
Next cell
Next col
End Sub
26- کمترین مقدار در یک یا چند ستون را مشخص کنید
Sub HighlightMinValue()
Dim cell As Range
Dim minVal As Double
‘ Use Excel’s MIN function to find the maximum value in the selected range
minVal = Application.WorksheetFunction.Min(Selection)
‘ Loop through each cell in the selected range to highlight the maximum value
For Each cell In Selection
If cell.Value = minVal Then
cell.Interior.ColorIndex = 3 ‘ Highlight with red color
End If
Next cell
End Sub
در صورتی که انتخاب شما شامل چندین ستون است و می خواهید حداقل مقدار را در هر ستون برجسته کنید، می توانید از کد زیر استفاده کنید:
Sub HighlightMinValueInEachColumn()
Dim cell As Range
Dim col As Range
Dim minVal As Double
‘ Loop through each column in the selected range
For Each col In Selection.Columns
‘ Use Excel’s Min function to find the minimum value in the current column
minVal = Application.WorksheetFunction.Min(col)
‘ Loop through each cell in the current column to highlight the maximum value
For Each cell In col.Cells
If cell.Value = minVal Then
cell.Interior.ColorIndex = 3 ‘ Highlight with red color
End If
Next cell
Next col
End Sub
27- همه مقادیر را در یک عدد ضرب کنید
Sub MultiplyValuesByNumber()
Dim cell As Range
Dim multiplier As Double
' Set the multiplier value
multiplier = 2 ' Replace this with the number by which you want to multiply
' Loop through each cell in the selected range
For Each cell In Selection
' Check if the cell contains a numeric value
If IsNumeric(cell.Value) Then
' Multiply the cell value by the multiplier
cell.Value = cell.Value * multiplier
End If
Next cell
End Sub
28- فاصله های اضافی را از سلول ها حذف کنید
Sub RemoveExtraSpaces()
Dim cell As Range
' Loop through each cell in the selected range
For Each cell In Selection
' Check if the cell contains a string value
If cell.HasFormula = False And IsEmpty(cell.Value) = False Then
' Remove extra spaces
cell.Value = WorksheetFunction.Trim(cell.Value)
End If
Next cell
End Sub
29- استخراج اعداد از متن
در اینجا یک کد VBA وجود دارد که تمام اعداد را از سلول های حاوی متن استخراج می کند. می توانید ستون متن را انتخاب کنید و کد را اجرا کنید.
Sub ExtractNumbers()
Dim cell As Range
Dim str As String
Dim numStr As String
Dim i As Integer
' Loop through each cell in the selected range
For Each cell In Selection
' Initialize numStr to an empty string
numStr = ""
' Retrieve the text from the cell
str = cell.Value
' Loop through each character in the string
For i = 1 To Len(str)
' Check if the character is numeric
If IsNumeric(Mid(str, i, 1)) Then
' Add the numeric character to numStr
numStr = numStr & Mid(str, i, 1)
End If
Next i
' Place the extracted numbers in the adjacent column (one column to the right)
cell.Offset(0, 1).Value = numStr
Next cell
End Sub
30- تبدیل به حروف بزرگ
Sub ConvertToUpperCase()
Dim cell As Range
' Loop through each cell in the selected range
For Each cell In Selection
' Check if the cell contains text and is not empty
If cell.HasFormula = False And IsEmpty(cell.Value) = False Then
' Convert the text in the cell to uppercase
cell.Value = UCase(cell.Value)
End If
Next cell
End Sub
31- تبدیل به حروف کوچک
Sub ConvertToLowerCase()
Dim cell As Range
' Loop through each cell in the selected range
For Each cell In Selection
' Check if the cell contains text and is not empty
If cell.HasFormula = False And IsEmpty(cell.Value) = False Then
' Convert the text in the cell to lowercase
cell.Value = LCase(cell.Value)
End If
Next cell
End Sub
32- تبدیل به Proper Case
Sub ConvertToProperCase()
Dim cell As Range
' Loop through each cell in the selected range
For Each cell In Selection
' Check if the cell contains text and is not empty
If cell.HasFormula = False And IsEmpty(cell.Value) = False Then
' Convert the text in the cell to proper case
cell.Value = WorksheetFunction.Proper(cell.Value)
End If
Next cell
End Sub
33- تبدیل به حالت استاندار حروف جمله (اولین کلمه حرف بزرگ و سایر کلمه به حروف کوچک تبدیل می گردد)
Sub ConvertToSentenceCase()
Dim cell As Range
Dim content As String
Dim i As Long
' Loop through each cell in the selected range
For Each cell In Selection
' Check if the cell contains text and is not empty
If cell.HasFormula = False And IsEmpty(cell.Value) = False Then
content = LCase(cell.Value) ' Convert the entire string to lowercase
' Capitalize the first letter of the string
Mid(content, 1, 1) = UCase(Mid(content, 1, 1))
' Capitalize the first letter after each period followed by a space
For i = 1 To Len(content) - 2
If Mid(content, i, 2) = ". " Then
Mid(content, i + 2, 1) = UCase(Mid(content, i + 2, 1))
End If
Next i
' Set the cell value to the converted string
cell.Value = content
End If
Next cell
End Sub
34- حذف اعشار از اعداد
Sub RemoveDecimalsFromNumbers()
Dim cell As Range
' Loop through each cell in the selection
For Each cell In Selection
' Check if the cell contains a numeric value
If IsNumeric(cell.Value) Then
' Remove the decimal and update the cell value
cell.Value = Round(cell.Value, 0)
End If
Next cell
End Sub
35- در تمام اعداد یک عدد اضافه یا تفریق کنید
Sub AddSubtractFromNumbers()
Dim cell As Range
Dim addValue As Double
' Define the value to add or subtract
' Change this to the value you want to add or subtract
addValue = 5
' Loop through each cell in the selected range
For Each cell In Selection
' Check if the cell contains a numeric value
If IsNumeric(cell.Value) Then
' Add or subtract the specified value and update the cell
cell.Value = cell.Value + addValue
End If
Next cell
End Sub
36- علائم منفی را حذف کنید
Sub RemoveNegativeSigns()
Dim cell As Range
' Loop through each cell in the selected range
For Each cell In Selection
' Check if the cell contains a numeric value
If IsNumeric(cell.Value) Then
' Remove the negative sign by taking the absolute value
cell.Value = Abs(cell.Value)
End If
Next cell
End Sub
37- حذف متن در پرانتز
Sub RemoveTextInParentheses()
Dim cell As Range
Dim regex As Object
Set regex = CreateObject("VBScript.RegExp")
' Regular Expression to find text in parentheses
regex.Pattern = "\([^)]*\)"
regex.Global = True
' Loop through each cell in the selected range
For Each cell In Selection
' Check if the cell contains text
If Not IsEmpty(cell.Value) Then
' Remove text in parentheses and update the cell
cell.Value = regex.Replace(cell.Value, "")
End If
Next cell
End Sub
38- ایجاد اعداد راندوم
Sub GenerateRandomNumbers()
Dim i As Integer
' Initialize the random number generator
Randomize
' Loop to generate 20 random numbers
For i = 1 To 20
' Generate random numbers between 1 and 100
' Write them to cells in column A
Cells(i, 1).Value = Int(Rnd * 100) + 1
Next i
End Sub
39- مخفی کردن جمع های فرعی جدول محوری (Pivot Table)
Sub HidePivotTableSubtotals()
Dim pt As PivotTable
Dim pf As PivotField
' Set the PivotTable object to the first PivotTable in the active sheet
Set pt = ActiveSheet.PivotTables(1)
' Loop through each PivotField in the PivotTable
For Each pf In pt.PivotFields
' Hide subtotals for the PivotField
pf.Subtotals(1) = False
Next pf
End Sub
40- بازخوانی خودکار جدول محوری
Sub AutoRefreshPivotTables()
Dim pt As PivotTable
Dim ws As Worksheet
' Set the worksheet object to the active sheet
Set ws = ActiveSheet
' Loop through all Pivot Tables in the worksheet
For Each pt In ws.PivotTables
' Refresh each Pivot Table
pt.RefreshTable
Next pt
End Sub
در صورتی که می خواهید تمام جداول محوری در کتاب کار را به روز کنید، می توانید از مثال کد VBA زیر استفاده کنید:
Sub AutoRefreshPivotTablesInWorkbook()
Dim pt As PivotTable
Dim ws As Worksheet
Dim wb As Workbook
' Set the workbook object to the active workbook
Set wb = ActiveWorkbook
' Loop through each worksheet in the workbook
For Each ws In wb.Worksheets
' Loop through all Pivot Tables in each worksheet
For Each pt In ws.PivotTables
' Refresh each Pivot Table
pt.RefreshTable
Next pt
Next ws
End Sub
41- حذف همه نمودارها از صفحه فعال
Sub DeleteAllCharts()
Dim chtObj As ChartObject
Dim ws As Worksheet
' Reference to the active worksheet
Set ws = ActiveSheet
' Loop through all the chart objects in the worksheet
For Each chtObj In ws.ChartObjects
' Delete each chart object
chtObj.Delete
Next chtObj
End Sub
اگر می خواهید همه نمودارها را از کل کتاب کار اکسل حذف کنید، می توانید از کد VBA زیر استفاده کنید:
Sub DeleteAllChartsInWorkbook()
Dim ws As Worksheet
Dim chtObj As ChartObject
' Loop through each worksheet in the workbook
For Each ws In ThisWorkbook.Worksheets
' Loop through each chart object in the worksheet
For Each chtObj In ws.ChartObjects
' Delete the chart object
chtObj.Delete
Next chtObj
Next ws
End Sub
42- همه نمودارها را با طول و عرض یکسان بسازید
Sub MakeAllChartsSameSize()
Dim ws As Worksheet
Dim chtObj As ChartObject
Dim newWidth As Double, newHeight As Double
' Desired dimensions for all chart objects
newWidth = 300
newHeight = 200
' Loop through each worksheet in the workbook
For Each ws In ThisWorkbook.Worksheets
' Loop through each chart object in the worksheet
For Each chtObj In ws.ChartObjects
' Resize the chart object
chtObj.Width = newWidth
chtObj.Height = newHeight
Next chtObj
Next ws
End Sub
43- اعمال مرز برای همه نمودارها
Sub ApplyBorderToAllCharts()
Dim ws As Worksheet
Dim cht As ChartObject
Dim brd As Border
' Loop through each worksheet in the workbook
For Each ws In ThisWorkbook.Worksheets
' Loop through each chart object in the worksheet
For Each cht In ws.ChartObjects
' Apply a border to the chart area
With cht.Chart.ChartArea.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0) ' Black color
.Weight = 1 ' Weight of the line (can be adjusted)
End With
Next cht
Next ws
End Sub
44- تمام نمودارها را به تصویر تبدیل کنید
Sub ConvertChartsToImages()
Dim ws As Worksheet
Dim cht As ChartObject
Dim chtCounter As Long
' Initialize the chart counter
chtCounter = 1
' Loop through each worksheet in the workbook
For Each ws In ThisWorkbook.Worksheets
' Loop through each chart object in the worksheet
For Each cht In ws.ChartObjects
' Export the chart to an image file (PNG format)
cht.Chart.Export "C:\Temp\Chart" & chtCounter & ".png"
' Increment the chart counter
chtCounter = chtCounter + 1
Next cht
Next ws
End Sub
45- تغییر نوع نمودار
Sub ChangeAllChartsToLine()
Dim ws As Worksheet
Dim cht As ChartObject
' Loop through each worksheet in the workbook
For Each ws In ThisWorkbook.Worksheets
' Loop through each chart object in the worksheet
For Each cht In ws.ChartObjects
' Change the chart type to Line Chart
cht.Chart.ChartType = xlLine
Next cht
Next ws
End Sub
46- قالب بندی یک نمودار را روی نمودار دیگر اعمال کنید
Sub CopyChartFormat()
Dim srcChart As Chart
Dim destChart As Chart
' Set the source and destination charts
Set srcChart = Sheets("Sheet1").ChartObjects("Chart 1").Chart
Set destChart = Sheets("Sheet2").ChartObjects("Chart 2").Chart
' Copy the entire chart to copy formatting
srcChart.Copy
' Paste the formatting to the destination chart
destChart.Paste Type:=xlPasteFormats
End Sub
47- دستور چاپ
Sub PrintComments()
Dim ws As Worksheet
Set ws = ActiveSheet ' Reference to the active worksheet
' Store the current print settings
Dim originalSetting As XlPrintLocation
originalSetting = ws.CommentsLayout
' Change the comments layout to print as end of sheet
ws.CommentsLayout = xlCommentsPrintAsEndOfSheet
' Print the active worksheet
ws.PrintOut
' Restore original print settings
ws.CommentsLayout = originalSetting
End Sub
48- چاپ محدوده انتخاب شده
Sub PrintSelectedRange()
Dim rng As Range ' Declare a variable to hold the selected range
' Check if a range is selected
If TypeName(Selection) = "Range" Then
Set rng = Selection ' Set the variable to the selected range
' Print the selected range
rng.PrintOut
Else
MsgBox "Please select a range to print."
End If
End Sub
49- فهرست مطالب را ایجاد کنید
Sub CreateTableOfContents()
Dim ws As Worksheet
Dim wsTOC As Worksheet
Dim i As Integer
' Create a new worksheet for the Table of Contents
Set wsTOC = ThisWorkbook.Sheets.Add(Before:=ThisWorkbook.Sheets(1))
wsTOC.Name = "Table_of_Contents"
' Set the header for the Table of Contents
wsTOC.Cells(1, 1).Value = "Table of Contents"
wsTOC.Cells(1, 1).Font.Bold = True
' Initialize counter
i = 2
' Loop through each worksheet in the workbook
For Each ws In ThisWorkbook.Sheets
' Skip the Table of Contents sheet
If ws.Name <> "Table_of_Contents" Then
' Write the sheet name in the TOC
wsTOC.Cells(i, 1).Value = ws.Name
' Create a hyperlink to the sheet
wsTOC.Hyperlinks.Add _
Anchor:=wsTOC.Cells(i, 1), _
Address:="", _
SubAddress:="'" & ws.Name & "'!A1", _
TextToDisplay:=ws.Name
' Increment counter
i = i + 1
End If
Next ws
End Sub
50- همه فایل های اکسل را در یک پوشه مشخص باز می کند
Sub OpenAllExcelFilesInFolder()
Dim folderPath As String
Dim fileName As String
Dim wb As Workbook
' Specify the folder path where the Excel files are stored
folderPath = "C:\YourFolder\"
' Check if the folder path ends with a backslash, if not, add one
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
' Get the first Excel file in the folder
fileName = Dir(folderPath & "*.xls*")
' Loop through each Excel file in the folder
Do While fileName <> ""
' Open the Excel file
Set wb = Workbooks.Open(folderPath & fileName)
' Do something with the workbook (optional)
' Get the next Excel file in the folder
fileName = Dir
Loop
End Sub
51- برگه فعال را به صورت PDF تبدیل و ذخیره می کند
Sub SaveActiveSheetAsPDF()
Dim ws As Worksheet
Dim pdfFileName As String
' Reference to the active worksheet
Set ws = ActiveSheet
' Define the PDF file name and path
pdfFileName = "C:\YourFolder\" & ws.Name & ".pdf"
' Save the active sheet as a PDF
ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfFileName, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
End Sub
52- هر کاربرگ را به عنوان یک PDF جداگانه ذخیره کنید
Sub SaveAllSheetsAsPDF()
Dim ws As Worksheet
Dim pdfFileName As String
Dim pdfFolder As String
' Define the folder to save PDFs
pdfFolder = "C:\YourFolder\"
' Loop through each worksheet in the workbook
For Each ws In ThisWorkbook.Sheets
' Generate PDF filename based on sheet name
pdfFileName = pdfFolder & ws.Name & ".pdf"
' Export each sheet as PDF
ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfFileName, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
Next ws
End Sub
53- کتاب کار را به صورت PDF تبدیل و ذخیره می کند
Sub SaveWorkbookAsPDF()
Dim pdfFileName As String
Dim pdfFolder As String
' Define the folder to save the PDF
pdfFolder = "C:\YourFolder\"
' Generate PDF filename based on the workbook name
pdfFileName = pdfFolder & ThisWorkbook.Name & ".pdf"
' Export the entire workbook as a single PDF
ThisWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfFileName, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
End Sub
54- محدوده انتخاب شده را به عنوان PDF ذخیره کنید
Sub SaveRangeAsPDF()
Dim pdfFileName As String
Dim selectedRange As Range
' Define the folder to save the PDF
pdfFileName = "C:\YourFolder\SelectedRange.pdf"
' Get the selected range
Set selectedRange = Selection
' Export the selected range as PDF
selectedRange.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfFileName, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
End Sub
55-متن خاص سلول ها را برجسته کنید
Sub HighlightSpecificText()
Dim ws As Worksheet
Dim cell As Range
Dim specificText As String
' Set specific text to look for
specificText = "Excel"
' Reference to the active worksheet
Set ws = ActiveSheet
' Loop through each cell in the used range
For Each cell In ws.UsedRange.Cells
' Check if the cell contains the specific text
If InStr(1, cell.Value, specificText, vbTextCompare) > 0 Then
' Highlight the cell in yellow (ColorIndex 6)
cell.Interior.ColorIndex = 6
End If
Next cell
End Sub
یک رشته متن خاص را تنظیم می کند که می خواهیم در هر سلول جستجو کنیم. در اینجا، آن بر اساس کلمه "اکسل" تنظیم شده است. می توانید این متن را در کد تغییر دهید.
56- تغییر اندازه همه تصاویر
Sub ResizeAllImages()
Dim img As Picture
Dim newWidth As Single, newHeight As Single
' Specify the new dimensions for images
newWidth = 100
newHeight = 100
' Loop through each picture on the active sheet
For Each img In ActiveSheet.Pictures
' Resize the image to the new dimensions
img.Width = newWidth
img.Height = newHeight
Next img
End Sub
در صورتی که علاقمند به آشنایی بیشتر با دوره های آموزشی و کاریردی اکسل هستید می توانید در این بخش (+) آموزشهای متنوع اکسل و ماکرو را مشاهده بفرمایید.
