برای داشتن امکانات ویژه اکسل کافیست این آموز را با دقت دنبال کنید تا بتوانید کارهای خود را با سرعت بالاتر و بهتر پیش ببرید. به عنوان مثال در اولین قدم میخواهیم اضافه کردن چک باکس در اکسل را با یک کلیک انجام دهیم.
فهرست محتوا
اضافه کردن Personal Macro به اکسل
یک فایل اکسل باز کنید و سعی کنید در آن واحد همین یک فایل باز باشد ، مهم نیست که فایل دارای اطلاعات باشد یا خام باشد . مراحل زیر را طی کنید تا ماکروهای شخصی خود را در تمام فایلهای اکسل این کامپیوتر داشته باشد.
- به تب Developer بروید و روی گزینه Record Macro کلیک کنید
- در پنجره باز شده گزینه Personal Macro را مانند تصویر انتخاب کنید.
- رو گزینه OK کلیک کنید .
- حالا روی Stop Recording کلیک کنید .
- با زدن کلیدهای Alt + F11 به کدنویسی بروید ، خواهید دید که Personal.xlsb اضافه شده است.
- فایل را ذخیره کنید ، کار تمام است و بخش اول را انجام داده اید.
افزودن امکانات ویژه اکسل
بخش اول کار را که در واقع یک بار انجام می دهیم را در مرحله قبل انجام دادیم و حالا وقت آن رسیده که از این قابلیت استفاده کنیم و کافیست که مراحل زیر را انجام دهیم و از اکسل لذت بیشتری ببریم.
- با زدن کلیدهای Alt + F11 به قسمت کدنویسی اکسل می رویم
- در قسمت چپ که فایلها و آبجکتها وجود دارد روی Personal.xlsb کلیک میکنیم.
- پوشه Module را باز میکنیم و Module1 را انتخاب می کنیم
- نام آن را به Main تغییر می دهیم که البته این دلخواه است .
- روی Main دابل کلیک میکنیم و حالا فضای خالی سمت راست آماده است
افزودن چک باکس با یک کلیک
قبلا مفصل در مورد چک باکس در اکسل آموزش داده ایم و به دلیل اهمیت آن به عنوان اولین مورد از امکانات ویژه اکسل قرار است که به برنامه اکسل خود اضافه کنیم . کافیست که کدهای زیر را در ماژول Main که در مراحل قبل ایجاد کردیم قرار دهیم.
کدهای مورد نیاز چک باکس
Sub AddCheckboxes()
Dim targetRange As Range
Dim cell As Range
Dim checkbox As Object
Dim response As VbMsgBoxResult
Dim defaultAddress As String
Dim strMasg As String
strMsg = ChrW(1605) & ChrW(1581) & ChrW(1583) & ChrW(1608) & ChrW(1583) & ChrW(1607) & ChrW(32) & ChrW(1575) & ChrW(1606) & ChrW(1578) & ChrW(1582) & ChrW(1575) & ChrW(1576) & ChrW(1740) & ChrW(32) & ChrW(1583) & ChrW(1575) & ChrW(1585) & ChrW(1575) & ChrW(1740) & ChrW(32) & ChrW(1575) & ChrW(1591) & ChrW(1604) & ChrW(1575) & ChrW(1593) & ChrW(1575) & ChrW(1578) & ChrW(32) & ChrW(1575) & ChrW(1587) & ChrW(1578) & ChrW(32) & ChrW(1548) & ChrW(32) & ChrW(1580) & ChrW(1575) & ChrW(1740) & ChrW(1711) & ChrW(1586) & ChrW(1740) & ChrW(1606) & ChrW(32) & ChrW(1588) & ChrW(1608) & ChrW(1583) & ChrW(32) & ChrW(1567)
defaultAddress = Selection.Address
Set targetRange = Selection
If targetRange Is Nothing Then
Exit Sub
End If
For Each cell In targetRange
If cell.Value <> "" Then
response = MsgBox(strMsg, vbYesNo + vbMsgBoxRight + vbExclamation, "officebaz.ir")
If response = vbNo Then Exit Sub
Exit For
End If
Next cell
For Each cell In targetRange.Cells
cell.Font.Color = cell.Interior.Color
Set checkbox = ActiveSheet.CheckBoxes.Add(cell.Left, cell.Top, cell.Width, cell.Height)
With checkbox
.LinkedCell = cell.Address
.Caption = ""
.Name = "chk_" & cell.Address
.Width = 14
.Height = 14
.Top = cell.Top + (cell.Height - .Height) / 2
.Left = cell.Left + (cell.Width - .Width) / 2
End With
Next cell
End Subبرای اینکه بتوانیم کدهای بالا را در تمام فایلهای اکسل این کامپیوتر ران کنیم کافیست کارهایی که در ویدیو آموزشی اول مطلب قرار دادم را انجام دهید .
پیشنهاد شما برای تکمیل امکانات ویژه اکسل
تا اینجا در این آموزش فقط نحوه اضافه کردن چک باکس با یک کلیک را اضافه کردیم و قطعا می توان قابلیتهای دیگری به اکسل افزود تا کار را سرع تر و بهتر انجام دهیم .
چیزی که به فکر خودم می رسد تا اینجا اینست که یک گزینه برای نمایش قیمت لحظه ای دلار اضافه کنم.
شما اگر چیزی دیگری به ذهنتان می رسد تا امکانات ویژه اکسل را افزایش دهیم حتما در قسمت نظرات عنوان نمائید.
نمایش نرخ ارز به صورت آنلاین در اکسل
در این بخش از امکانات ویژه اکسل می خواهیم بحث نمایش قیمت دلار و درهم را به صورت آنلاین در برنامه اکسل داشته باشیم .
در این آموزش دو روش را بررسی کردم که هر دو روش در ویدیو توضیح داده شده و به دلیل مشکلی که روش اول داشت ، به ناچار از روش بعدی استفاده کردم که به فایل کمکی اکسل نیازی ندارد.
برای اینکه بتوانید قیمت ارزهای دلار و درهم را به صورت لحطه ای در اکسل داشته باشید ، کافیست ویدیو زیر را مشاهده کنید و کدهایی که در ادامه آن آورده شده است را به PERSONALMACRO.XLSB که قبلا در مورد آن صحبت کردیم اضافه کنید . این هم یکی دیگز از امکانات ویژه اکسل 👍
کدهای مورد نیاز برای نمایش قیمت ارز در اکسل
Sub ExtractTableFromWebAndFormat()
' متغيرها
Dim webURLs(1 To 2) As String
Dim html As Object
Dim tableNumber As Integer
Dim table As Object
Dim targetRanges(1 To 2) As Range
Dim priceSheet As Worksheet
' تنظيمات اوليه
webURLs(1) = "https://www.tgju.org/profile/price_dollar_rl"
webURLs(2) = "https://www.tgju.org/profile/price_aed"
tableNumber = 0 ' شماره جدول مورد نظر
' چک کردن و حذف شيت "Price" اگر وجود داشته باشد
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Price").Delete
Application.DisplayAlerts = True
On Error GoTo 0
' ايجاد شيت جديد با نام "Price"
Set priceSheet = Sheets.Add(After:=Sheets(Sheets.Count))
priceSheet.Name = "Price"
' درخواست به وب سايت و دريافت جدول
For i = 1 To 2
With CreateObject("MSXML2.ServerXMLHTTP")
.Open "GET", webURLs(i), False
.send
Set html = CreateObject("htmlfile")
html.body.innerHTML = .responseText
End With
' دريافت جدول مورد نظر
Set table = html.getElementsByTagName("table")(tableNumber)
' تعيين محدوده مقصد (سلول شروع)
Set targetRanges(i) = priceSheet.Cells(2, (i - 1) * 3 + 1)
priceSheet.Range("a1").Value = "نرخ دلار"
priceSheet.Range("d1").Value = "نرخ درهم"
' نمايش جدول در محدوده مقصد
InsertTableIntoWorksheet table, targetRanges(i)
Next i
' تغييرات فرمت دهي
ApplyFormattingToSheet priceSheet
End Sub
Sub InsertTableIntoWorksheet(table As Object, targetRange As Range)
' متغيرها
Dim rowCounter As Long
Dim columnCounter As Integer
Dim tableRow As Object
Dim tableCell As Object
' شروع از سلول مقصد
rowCounter = targetRange.Row
columnCounter = targetRange.Column
' پيمايش سطرها و ستونهاي جدول
For Each tableRow In table.Rows
For Each tableCell In tableRow.Cells
' قرار دادن مقدار در ورکشيت
targetRange.Offset(rowCounter - targetRange.Row, columnCounter - targetRange.Column).Value = tableCell.innerText
columnCounter = columnCounter + 1
Next tableCell
' بازنشاني شماره ستون به ستون مقصد براي شروع ستون جديد
columnCounter = targetRange.Column
rowCounter = rowCounter + 1
Next tableRow
' تنظيمات نمايش ورکشيت
With targetRange.Resize(1, 2).Interior
.Color = RGB(200, 200, 200) ' تغيير رنگ بکگراند دو ستون اول
End With
targetRange.Resize(, 2).EntireColumn.AutoFit ' اندازهگيري خودکار عرض دو ستون اول
End Sub
Sub ApplyFormattingToSheet(ws As Worksheet)
' محدودههايي که بايد فرمت دهي شوند
Dim rangeToFormat As Range
Set rangeToFormat = Union(ws.Range("A2:B12"), ws.Range("D2:E12"))
' تغيير فونت به VazirMatn FD
ws.Cells.Font.Name = "VazirMatn FD"
ActiveSheet.DisplayRightToLeft = True
' غيرفعال کردن خطوط شبکه (Gridlines)
ws.Activate
ActiveWindow.DisplayGridlines = False
rangeToFormat.Borders(xlDiagonalDown).LineStyle = xlNone
rangeToFormat.Borders(xlDiagonalUp).LineStyle = xlNone
With rangeToFormat.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.499984740745262
.Weight = xlThin
End With
With rangeToFormat.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.499984740745262
.Weight = xlThin
End With
With rangeToFormat.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.499984740745262
.Weight = xlThin
End With
With rangeToFormat.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.499984740745262
.Weight = xlThin
End With
With rangeToFormat.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.499984740745262
.Weight = xlThin
End With
With rangeToFormat.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.499984740745262
.Weight = xlThin
End With
Columns("A:A").EntireColumn.AutoFit
Columns("D:D").EntireColumn.AutoFit
Range("B:B,E:E").Select
Range("E1").Activate
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A2").Select
End Sub
ساخت پوشه با یک کلیک
فرض کنید که در محدوده A1:A10 لیستی از نام پرسنل دارید و یمخواهید برای هر کدام از آنها یک پوشه به نام ایشان بسازید و این کار را میخواهید خیلی سریع انجام دهید . چاره کار استفاده از دستورات VBA است که در ادامه به آن خواهیم پرداخت.
البته اگر بخواهیم جزئی از امکانات ویژه اکسل در نظر نگیریم ، قبلا در مورد ساخت پوشه در اکسل البته با روشی دیگر آموزش داده ایم که بررسی آن آموزش هم خالی از لطف نیست .
برای انجام این کار کافیست مراحل زیر را انجام دهید :
- کدهایی که در ادامه قرار داده شده را کپی کنید
- فایل اکسل را باز کنید و با زدن Alt + F11 به کد نویسی بروید.
- ماژول Main از فایل Personal Macro.xlsb را انتخاب کنید .
- کدهای کپی شده را آنجا قرار دهید .
البته لازم به ذکر است که حتما ویدیو ابتدایی این آموزش را ببینید تا در جریان قرار بگیرید 😎 که چگونه امکانات ویژه اکسل را در کامپیوتر خود داشته باشید.
کدهای مورد نیاز برای ساخت پوشه
Sub CreateFoldersBasedOnSelection()
Dim selectedRange As Range
Dim cell As Range
Dim folderPath As String
' انتخاب محدوده از کاربر
On Error Resume Next
Set selectedRange = Application.InputBox("لطفاً يک محدوده انتخاب کنيد:", Type:=8)
On Error GoTo 0
' اگر کاربر کنسل کرد يا محدوده انتخاب نشد، از اجرا خارج شويد
If selectedRange Is Nothing Then
Exit Sub
End If
' انتخاب مسير براي ايجاد پوشهها
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "لطفاً يک مسير براي ايجاد پوشهها انتخاب کنيد:"
If .Show = -1 Then
folderPath = .SelectedItems(1) & "\"
Else
Exit Sub
End If
End With
' ايجاد پوشه براي هر سلول در محدوده
For Each cell In selectedRange
Dim cellValue As String
cellValue = Trim(cell.Value)
' اطمينان حاصل کنيد که نام پوشه خالي نيست
If cellValue <> "" Then
' ايجاد مسير کامل با ترکيب مسير اصلي و نام سلول
Dim fullPath As String
fullPath = folderPath & cellValue
' اگر پوشه وجود نداشته باشد، آن را ايجاد کنيد
If Dir(fullPath, vbDirectory) = "" Then
MkDir fullPath
End If
End If
Next cell
MsgBox "پوشهها با موفقيت ايجاد شدند!", vbInformation + vbMsgBoxRight, "Officebaz.ir"
End Sub
ایجاد پسورد قوی و استاندارد
آموزشی قبلا داده ایم که چگونه پسوردهای استاندارد و قوی در اکسل ایجاد کنید و در این قسمت میخواهیم با چند خط کد کاری کنیم که با یک کلیک یک پسورد 16 کاراکتری قوی ایجاد شود و فقط کارهای زیر را انجام دهید.
- مانند مراحل قبل پیش بروید تا PersonalMacro.xlsb را بتوانید ویرایش کنید
- کدهای زیر را به انتهای ماژول اضافه کنید
- برای افزودن به ریبون هم از همان روش که در ابتدای مطلب توضیح دادیم استفاده کنید
کدهای مورد نیاز برای ایجاد پسورد
Sub GeneratePassword()
Dim characters As String
Dim length As Integer
Dim i As Integer
Dim GeneratedPassword As String
' بررسي سلول فعال براي وجود داده
If ActiveCell.Value <> "" Then
MsgBox "سلول داراي اطلاعات است", vbMsgBoxRight + vbInformation, "Officebaz.ir"
Exit Sub
End If
characters = "!#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz}~"
length = 16
GeneratedPassword = ""
Randomize
For i = 1 To length
GeneratedPassword = GeneratedPassword & Mid(characters, Int((Len(characters) * Rnd) + 1), 1)
Next i
' نوشتن پسورد توليدشده در سلول فعلي
ActiveCell.Value = GeneratedPassword
End Sub
تهیه پشتیبان از فایل اکسل
برای اینکه یک نسخه از فایل اکسلی که در حال کار با آن هستید را به راحتی بتوانید ذخیره کنید و به ان دسترسی داشته باشید می توانید از کدهای زیر استفاده کنید .
مراحل اولیه کار مانند ابتدای این آموزش هست و فقط باید کدهای زیر را هم به فایل PersonalMacro.xlsb اضافه کنید .
Sub officebazBackup()
Dim CurrentFileName As String
Dim BackupPath As String
Dim BackupFileName As String
Dim FileExtension As String
Dim fso As Object
' مشخص کردن نام فايل جاري
CurrentFileName = ActiveWorkbook.FullName
' مشخص کردن مسير پوشه backup
BackupPath = "D:\backup\"
' بررسي وجود پوشه backup و ايجاد آن اگر وجود نداشت
If Dir(BackupPath, vbDirectory) = "" Then
MkDir BackupPath
End If
' استخراج پسوند فايل جاري
FileExtension = Right(CurrentFileName, Len(CurrentFileName) - InStrRev(CurrentFileName, "."))
' ايجاد يک شيء FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
' تنظيم نام فايل بک آپ با نام فايل جاري، تاريخ و زمان فعلي و پسوند مورد نظر
BackupFileName = BackupPath & fso.GetBaseName(CurrentFileName) & "_Backup_" & Format(Now, "yyyy-mm-dd_hhmmss") & "." & FileExtension
' ذخيره فايل جاري با نام جديد
ActiveWorkbook.Save
ActiveWorkbook.SaveAs BackupFileName
' بستن فايل جاري
' ActiveWorkbook.Close SaveChanges:=False
' نمايش پيام به کاربر
MsgBox "فايل با موفقيت ذخيره شده و يک نسخه هم در مسير " & vbCrLf & vbCrLf & BackupPath & vbCrLf & vbCrLf & " قرار گرفت ", vbInformation + vbMsgBoxRight, "Officebaz.ir"
End Subفقط دقت داشته باشید که در این کدها ، مسیر ذخیره سازی فایلها D:\Backup می باشد که در صورت تمایل می توانید آن را تغییر دهید .
ایجاد محدوده نام برای هر شیت
فرض کنید که یک فایل اکسل دارید حاوی بیش از 10 شیت که میخواهید به این شیتها دسترسی سریع داشته باشید ، یک راه ایجاد محدوده نام برای هر شیت یه نام همان شیت است.
با اضافه کردن کدهای زیر ، وقتی اجرا شوند از تمام شیتها یک نام ایجاد می کند
برای حذف و ویرایش نامه هم کافیست که کلیدهای ctrl + f3 را بزنید .
Sub creatNamebox()
Dim ws As Worksheet
Dim i As Integer
For Each ws In ActiveWorkbook.Worksheets
i = i + 1
ActiveWorkbook.Names.Add Name:=ws.Name, RefersTo:=ws.Range("A1")
Next ws
End Subتا اینجا 6 قابلیت را در قالب امکانات ویژه اکسل در این مطلب آموزش داده ایم و در قسمت نظرات منتظر ایده و پیشنهادات شما هستسم تا بتوانیم این امکانات ویژه اکسل را توسعه دهیم . اگر توضیح کدها در ویدیوها برای شما گنگ است پیشنهاد می کنم دوره VBA اکسل را مشاهده نمائید.
ایجاد شیت INDEX شامل نام تمام شیتها
فرض میکنیم که فایل اکسل داریم که حاوی تعداد زیادی شیت است و جابجایی بین شیتها کمی زمان بر می باشد با کدهایی که در ادامه قرار داده می شود ، و با اجرای آن یک جدید به فیا شا اضافه می شود به نام INDEX که در ستون B آن نام شیتها قرار می گیرد.
با کلیک بر روی هر نام به همان شیت منتقل خواهید شده و HYPERLINK می شود و علاوه بر آن اگر آدرس A1 شیتها خالی باشند در هر شیت هم نوشته Back در A1 قرار میگرد که با کلیک روی آن به شیت INDEX منتقل می شود .
