با درود
ضمن تشکر از جناب آقای generalsamad در تکمیل آموزش و بنا به در خواست ایشان کدنویسی vba ماتریس متقارن به همراه فایل نمونه تقدیم دوستان میگردد. امیدوارم برای دوستان مفید واقع شود.
توضیح عمکرد کد:
جهت ایجاد یک ماتریس متقارن کافیه در یکی از سلولها دوبارکلیک کنید، پس از آن از شما پرسیده میشود طول قطر ماتریس چه تعداد باشد که با وارد کردن طول قطر، ماتریس متقارن خالی به ابعاد مورد نظر تولید میشود. سپس شما در هر سلول از این ماتریس که مقداری وارد کنید در سلول متقارن آن، مقدار مربوطه ایجاد خواهد شد ضمن اینکه محدودیتی در وارد کردن کدام سمت مثلثی ماتریس ندارید، یعنی در هرسمت که مقدار وارد شد در سمت متقارن مثلث مقدار شما ایجاد میشود.
همچنین با دوبارکلیک مجدد در یک سلول شما می توانید ماتریس قبلی را کاملا حذف و ماتریس جدید با ابعاد دلخواه ایجاد کنید و در صورتیکه بخواهید بدون ایجاد ماتریس جدید ماتریس قبلی را حذف کنید پس از دوبارکلیلک در یک سلول و ظاهر شدن پرسش طول قطر ماتریس، مقدار صفر را وارد و اینتر کنید.
البته دوستان بسته به نیاز خود می توانند کد زیر را تغییر و استفاده کنند.
کد PHP:
Public Src As Range, Mtx As Range
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error Resume Next
Dim Vtr As Integer
p1 = "Please enter the dimension of Matrix:"
p2 = "(Enter '0' to erase Matrix)"
p = p1 + Chr(13) + Chr(13) + p2
t = "Enter Dimension"
ib = InputBox(p, t, 7)
If ib = "" Then Exit Sub Else Vtr = Val(ib)
If Vtr < 2 And Vtr <> 0 Then
MsgBox "Dimension of Matrix Not less than 2!", vbExclamation, "Error"
Cancel = True
Exit Sub
End If
If Not Mtx Is Nothing Then
Mtx.Clear
If Vtr = 0 Then Cancel = True: Exit Sub
End If
Set Mtx = Range(Target.Address & ":" & Target.Offset(Vtr - 1, Vtr - 1).Address)
Set Src = Target
Application.EnableEvents = False
Application.ScreenUpdating = False
Mtx.Clear
For i = Src.Row To Src.Row + Mtx.Rows.Count - 1
For j = Src.Column To Src.Column + Mtx.Columns.Count - 1
If i - Src.Row = j - Src.Column Then
Cells(i, j).Interior.Color = 15921906
ElseIf i - Src.Row < j - Src.Column Then
Cells(i, j).Interior.Color = 15849925
Else
Cells(i, j).Interior.Color = 14281213
End If
Next j
Next i
Mtx.Borders.LineStyle = xlContinuous
Application.EnableEvents = True
Application.ScreenUpdating = True
Cancel = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Dim Vtr As Integer
Vtr = Mtx.Columns.Count
If Target.Row < Src.Row Or Target.Row >= Src.Row + Vtr Then
Target.Interior.Pattern = xlNone
Exit Sub
End If
If Target.Column < Src.Column Or Target.Column >= Src.Column + Vtr Then
Target.Interior.Pattern = xlNone
Exit Sub
End If
Application.EnableEvents = False
Src.Offset(Target.Column - Src.Column, Target.Row - Src.Row).Value = Target.Value
Application.EnableEvents = True
End Sub
هرکاری کردم فایل با پسوند xlsm نشد آپ کنم و اجبارا اون رو به rar تبدیل و آپ کردم!!!!
علاقه مندی ها (Bookmarks)