ماکروهای ساده و کاربردی در اکسل

قبلا در مورد ماکرو در اکسل و راحت روش ایجاد آن در اکسل مطلبی منتشر کردیم و حالا می خواهیم 20 ماکرو بسیار کاربردی و البته ساده را معرفی کنیم که با استفاده از آنها می توانید در وقت خود به میزان قابل توجهی صرفه جویی کنید .

ویدیو آموزش استفاده از ماکروها

[su_box title=”دسترسی سریع  ” style=”soft” box_color=”#006300″]

نمایش تمام شیتهای مخفی شده در اکسل

مخفی کردن تمام شیتها به غیر از شیتی که فعال هست

شیتهای موجود در فایل اکسل را به ترتیب الفبا مرتب سازی می کند .

با یک کلیک تمام شیتهای اکسل خود را محافظت کنید

برعکس کد بالا عمل کرده و پسورد شیتها را بر می دارد .

تمام ردیفها و ستونهای فایل اکسل را از حالت مخفی خارج کنید .

سلولهایی که با هم یکی شده اند را از هم جدا کنید 

ذخیره کردن فایل اکسل جاری به نام تاریخ فعلی

ذخیره کردن شیتهای یک فایل اکسل با فرمکت PDF

فقط شیت جاری رو با فرمت PDF ذخیره می کنه

تمام فرمولهایی که استفاده کرده اید را به مقدار تبدیل می کند

سلولهای حاوی فرمول را قفل می کند

تمام شیتهای موجود در فایل اکسل را محافظت کنید

یک سطر بین تمام سطرهای انتخاب شده اضافه کنید

یک سطر در میان محدوده انتخابی را هایلایت می کند .

تمام پایوت تیبل های ایجاد شده را رفرش کنید

سلولهای دارای توضیحات رو هایلایت می کند

سلولهای خالی را رنگی می کند

استخراج داده های عددی که با فایل متنی وارد شده اند

استخراج داده های متنی یک محدوده

[/su_box]

1[sta_anchor id=”1″ /]- نمایش تمام شیتهای مخفی شده در اکسل

اگر با فایل اکسلی کار می کنید که حاوی تعدادی شیت مخفی است می توانید با ماکرو زیر و با یک کلیک همه آنها را نمایش دهید .

'این کد تمام شیتهای مخفی اکسل را نمایش می دهد
Sub UnhideAllWoksheets()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Visible = xlSheetVisible
Next ws
End Sub

2- [sta_anchor id=”2″ /]مخفی کردن تمام شیتها به غیر از شیت فعال توسط ماکرو در اکسل

برعکس کد بالا عمل می کند و تمام شیتهای اکسلی که باز است را مخفی می کند به غیر از شیت جاری

'به جز شیت جاری بقیه مخفی می شوند
Sub HideAllExceptActiveSheet()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> ActiveSheet.Name Then ws.Visible = xlSheetHidden
Next ws
End Sub

3-[sta_anchor id=”3″ /] شیتهای موجود در فایل اکسل را به ترتیب الفبا مرتب سازی می کند .

امکان دارد فایل اکسلی داشته باشید که از تعداد زیادی شیت تشکیل شده باشد و بخواهید شیتها را بر اساس نام مرتب سازی کنید . به عنوان مثال نام شیتها ماههای سال است .

'شیتهای فایل اکسل شما را به ترتیب الفبا مرتب می کند 
Sub SortSheetsTabName()
Application.ScreenUpdating = False
Dim ShCount As Integer, i As Integer, j As Integer
ShCount = Sheets.Count
For i = 1 To ShCount - 1
For j = i + 1 To ShCount
If Sheets(j).Name < Sheets(i).Name Then
Sheets(j).Move before:=Sheets(i)
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub

4- [sta_anchor id=”4″ /]با یک کلیک تمام شیتهای اکسل خود را محافظت کنید

با استفاده از کد زیر می توانید برای همه شیتهای فایل اکسل خود پسورد انتخاب کرده آنها رو قفل کنید ، در مثال زیر پسورد 123 در نظر گرفته شده که می توانید عوض کنید .

' برای همه شیتها پسورد در نظر گرفته و قفل می شوند
Sub ProtectAllSheets()
Dim ws As Worksheet
Dim password As String
password = "123" 
For Each ws In Worksheets
   ws.Protect password:=password
Next ws
End Sub

5- [sta_anchor id=”5″ /]برعکس کد بالا عمل کرده و پسورد شیتها را بر می دارد .

اگر شیتهای فایل اکسل خود را با رمز محافظت کرده باشید با کد زیر می توانید تمام پسوردها رو بردارید.

'پسورد شیتهای خود را بردارید 
Sub ProtectAllSheets()
Dim ws As Worksheet
Dim password As String
password = "123" ' 
For Each ws In Worksheets
ws.Unprotect password:=password
Next ws
End Sub

نکته : کد بالا در صورتی کار می کند که رمز شیتهای شما 123 باشد .

6- [sta_anchor id=”6″ /]تمام ردیفها و ستونهای فایل اکسل را از حالت مخفی خارج کنید .

با استفاده از کد زیر و تنها یک کلیک می توانید تمام ردیفها و ستونهایی که از دید شما پنهان شده اند را به نمایش در آورید.

'نمایش همه ستونها و ردیفها
Sub UnhideRowsColumns()
Columns.EntireColumn.Hidden = False
Rows.EntireRow.Hidden = False
End Sub

7- [sta_anchor id=”7″ /]سلولهایی که با هم یکی شده اند را از هم جدا کنید ، Merge و Unmerg

فایل اکسلی دارید که بعضی از سلولهای آن با هم یکی شده اند با استفاده از کد زیر به راحتی می توانید آنها جدا کنید .

'جدا کردن سلولهایی که با هم یکی شده اند 
Sub UnmergeAllCells()
ActiveSheet.Cells.UnMerge
End Sub

8- [sta_anchor id=”8″ /]ذخیره کردن فایل اکسل جاری به نام تاریخ فعلی

کد زیر فایل جاری رو با یه اسم منحصر به فرد در مسیر درایو D ذخیره می کنه .

نکته : اگر از تاریخ شمسی اکسل استفاده می کنید می تونید با تاریخ شمسی ذخیره کنید .

Sub SaveWorkbookWithTimeStamp()
Dim timestamp As String
timestamp = Format(Date, "dd-mm-yyyy") & "_" & Format(Time, "hh-ss")
ThisWorkbook.SaveAs "D:Officebaz" & timestamp
End Sub

9- [sta_anchor id=”9″ /]ذخیره کردن شیتهای یک فایل اکسل با فرمت PDF

فرض کنید فایل اکسلی دارید که 10 تا شیت مختلف داره با اجرای کد زیر می تونید فایل رو تو 10 تا فایل PDF جداگانه ذخیره کنید

نکته : برای استفاده از ماکرو زیر مطمئن شوید که در دریاو C پوشه ای با نام pdfs داشته باشید .

Sub createPDFfiles()
    Dim ws As Worksheet
    Dim Fname As String
    For Each ws In ActiveWorkbook.Worksheets
        On Error Resume Next 'Continue if an error occurs
        Fname = "Annex 1.1." & ws.Index & "_result"
        Fname = "C:\pdfs\" & ActiveWorkbook.Name & "-" & ws.Name
        ws.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=Fname, _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False
    Next ws
End Sub

نکته :

اگر بخواهید محدوده ثابتی از یک شیت را ذخیره کنید ، کد زیر مناسب شماست :

• هر عبارتی که در A1 وارد کرده باشید به عنوان نام در نظر گرفته میشود
• کد زیر محدوده A1:C1 را با فرمت PDF ذخیره می کند

Public Sub Save_Range_As_PDF_On_Desktop()
     
    Dim fileName As String, saveAsFileName As Variant
    Dim PDFrange As Range
    
    With ActiveSheet
        fileName = .Range("A1").Value & ".pdf"
        Set PDFrange = .Range("A1:C1")
    End With
    
    saveAsFileName = Application.GetSaveAsFilename(InitialFileName:=Get_SpecialFolderPath("Desktop") & fileName, _
                        FileFilter:="PDF file (*.pdf), *.pdf", _
                        Title:="Save PDF file")
    If saveAsFileName <> False Then
        PDFrange.ExportAsFixedFormat Type:=xlTypePDF, fileName:=saveAsFileName, _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    End If

End Sub


Private Function Get_SpecialFolderPath(SpecialFolderName As Variant) As String
    Get_SpecialFolderPath = CreateObject("WScript.Shell").SpecialFolders(SpecialFolderName) & "\"
End Function

10-[sta_anchor id=”10″ /] فقط شیت جاری رو با فرمت PDF ذخیره می کنه

کد بالا تک تک شیتها رو ذخیره می کرد و این کد فقط شیت جاری رو با پسوند PDF ذخیره می کنه ، البته فراموش نکنید که آدرس فولدر رو در کد زیر باید عوض کنید .

Sub PDFActiveSheet()
'for Excel 2010 and later
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
On Error GoTo errHandler

Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "yyyymmdd\_hhmm")

'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
  strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"

'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")

'create default name for savng file
strFile = strName & "_" & strTime & ".pdf"
strPathFile = strPath & strFile

'use can enter name and
' select folder for file
myFile = Application.GetSaveAsFilename _
    (InitialFileName:=strPathFile, _
        FileFilter:="PDF Files (*.pdf), *.pdf", _
        Title:="Select Folder and FileName to save")

'export to PDF if a folder was selected
If myFile <> "False" Then
    wsA.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=myFile, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    'confirmation message with file info
    MsgBox "PDF file has been created: " _
      & vbCrLf _
      & myFile
End If

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not create PDF file"
    Resume exitHandler
End Sub

11- [sta_anchor id=”11″ /]تمام فرمولهایی که استفاده کرده اید را به مقدار تبدیل می کند

داده های به دست آمده توسط فرمول را از حالت فرمول خارج می کند ( تمام فرمولهای استفاده شده )

'This code will convert all formulas into values
Sub ConvertToValues()
With ActiveSheet.UsedRange
.Value = .Value
End With
End Sub

12- [sta_anchor id=”12″ /]سلولهای حاوی فرمول را قفل می کند

اگر فایل اکسلی داشته باشید که حاوی فرمولهای مختلفی باشد به راحتی با استفاده از کدهای زیر می توانید از تمام سلولهای حاوی فرمول محافظت نمائید .

'This macro code will lock all the cells with formulas
Sub LockCellsWithFormulas()
With ActiveSheet
   .Unprotect
   .Cells.Locked = False
   .Cells.SpecialCells(xlCellTypeFormulas).Locked = True
   .Protect AllowDeletingRows:=True
End With
End Sub

13-[sta_anchor id=”13″ /] تمام شیتهای موجود در فایل اکسل را محافظت کنید

با استفاده از کد زیر تمام شیتها قفل می شود

'This code will protect all sheets in the workbook
Sub ProtectAllSheets()
Dim ws As Worksheet
For Each ws In Worksheets
ws.Protect
Next ws
End Sub

14- [sta_anchor id=”14″ /]یک سطر بین تمام سطرهای انتخاب شده اضافه کنید

'This code will insert a row after every row in the selection
Sub InsertAlternateRows()
Dim rng As Range
Dim CountRow As Integer
Dim i As Integer
Set rng = Selection
CountRow = rng.EntireRow.Count
For i = 1 To CountRow
ActiveCell.EntireRow.Insert
ActiveCell.Offset(2, 0).Select
Next i
End Sub

15-[sta_anchor id=”15″ /] یک سطر در میان محدوده انتخابی را هایلایت می کند .

This code would highlight alternate rows in the selection
Sub HighlightAlternateRows()
Dim Myrange As Range
Dim Myrow As Range
Set Myrange = Selection
For Each Myrow In Myrange.Rows
   If Myrow.Row Mod 2 = 1 Then
      Myrow.Interior.Color = vbCyan
   End If
Next Myrow
End Sub

16- [sta_anchor id=”16″ /]تمام پایوت تیبل های ایجاد شده را رفرش کنید

'This code will refresh all the Pivot Table in the Workbook
Sub RefreshAllPivotTables()
Dim PT As PivotTable
For Each PT In ActiveSheet.PivotTables
PT.RefreshTable
Next PT
End Sub

با استفاده از کد بالا می توانید پایوت تیبلهای موجود در شیت خود را به روزرسانی نمائید

17- [sta_anchor id=”17″ /]سلولهای دارای توضیحات رو هایلایت می کند

'This code will highlight cells that have comments`
Sub HighlightCellsWithComments()
ActiveSheet.Cells.SpecialCells(xlCellTypeComments).Interior.Color = vbBlue
End Sub

فرض کنید که فایل اکسلی دارید که دارای کامنت و یا توضیحات مختلفی در سلولهای خود می باشد . با استفاده از کد بالا تمام سلولهای حاوی کامنت هایلایت می شوند .

کانتهای سلولهای اکیل می تواند تصویری باشد .

18- [sta_anchor id=”18″ /]با این ماکرو در اکسل سلولهای خالی را رنگی کنید

'This code will highlight all the blank cells in the dataset
Sub HighlightBlankCells()
Dim Dataset as Range
Set Dataset = Selection
Dataset.SpecialCells(xlCellTypeBlanks).Interior.Color = vbRed
End Sub

قبلا در مورد سلولها خالی و پیدا کردن آنها مزلب داشته ایم و کد بالا تمام سلولهای خالی رنج انتخب شده را رنگی می کند .

19-[sta_anchor id=”19″ /] استخراج داده های عددی که با فایل متنی وارد شده اند

اگر فایل اکسلی مطابق عکس زیر داشته باشید ، به راحتی با استفاده از کد می توانید مقادیر عددی سلولها را جدا کنید.

Sub ExtrNumbersFromRange()
    Dim xRg As Range
    Dim xDRg As Range
    Dim xRRg As Range
    Dim nCellLength As Integer
    Dim xNumber As Integer
    Dim strNumber As String
    Dim xTitleId As String
    Dim xI As Integer
    xTitleId = "Officebaz.ir"
    Set xDRg = Application.InputBox("محدوده داده را انتخاب کنید:", xTitleId, "", Type:=8)
    If TypeName(xDRg) = "Nothing" Then Exit Sub
    Set xRRg = Application.InputBox("لطفا آدرس هدف را انتخاب کنید:", xTitleId, "", Type:=8)
    If TypeName(xRRg) = "Nothing" Then Exit Sub
    xI =  0
    strNumber = ""
  For Each xRg In xDRg
    xI = xI + 1
    nCellLength = Len(xRg)
    For xNumber = 1 To nCellLength
      If IsNumeric(Mid(xRg, xNumber, 1)) Then
        strNumber = strNumber & Mid(xRg, xNumber, 1)
      End If
    Next xNumber
    xRRg.Item(xI) = strNumber
    strNumber = ""
  Next xRg
End Sub

20- [sta_anchor id=”20″ /]استخراج داده های متنی یک محدوده

برعکس کد بالا عمل کرده و داده های متنی یک محدوده را از داده های عددی جدا می کند .

Function ExtractNumbers(strText As String)
'Declare the necessary variables.
Dim i As Integer, strDbl As String
'Loop through each character in the cell.
For i = 1 To Len(strText)
'If the character is a digit, append it to the strDbl variable.
If IsNumeric(Mid(strText, i, 1)) Then
strDbl = strDbl & Mid(strText, i, 1)
End If
Next i

ExtractNumbers = CDbl(strDbl)
End Function

Function ExtractLetters(strText As String)
'Declare the necessary variables.
Dim x As Integer, strTemp As String
'Loop through each character in the cell.
For x = 1 To Len(strText)
'If the character is not numeric, it must be a letter,
'so append it to the strTemp variable.
If Not IsNumeric(Mid(strText, x, 1)) Then
strTemp = strTemp & Mid(strText, x, 1)
End If
Next x
ExtractLetters = strTemp
End Function

امیدوارد که ماکروهای بالا مفید باشد و بتوانید از آنها بهره ببرید اگر شما هم ماکرویی به ذهنتان می رسد در نظرات عنوان نمائید تا به لیست بالا افزوده شود .