ماتریس متقارن

[generalsamad]

با سلام
با ترکیب این دو فرمول میتوان یک ماتریس متقارن ساخت
اول داده های قطر بالا مثلثی را وارد میکنیم سپس برای قطر پائین مثلثی از این فرمول استفاده میکنیم
دقت کنید برای این فرمول باید اولین خانه ماتریس جائی از شیت قرار بگیره که شماره سطر و ستون یکی باشند
بطور مثال اگه بخواهیم اولین خانه ماتریس در سطر 1 ایجاد کنیم شماره ستون هم باید 1 باشه که در کل آدرسش میشه a1
اگه بخواهیم اولین خانه ماتریس در سطر 1 ایجاد کنیم شماره ستون هم باید 1 باشه که در کل آدرسش میشه b2
اگه بخواهیم اولین خانه ماتریس در سطر 1 ایجاد کنیم شماره ستون هم باید 1 باشه که در کل آدرسش میشه c3

البته برای این فرمول اینطوره که میتونیم با کم یا زیاد کردن پارامترها به خواسته خود برسیم بدون اینکه موارد بالا رو رعایت کنیم

اینم فرمول

=indirect(address(column();row())) 

کافیه این فرمول رو برای کل قطر پائینی نوشت
در مورد توضیح کد بالا تنها نکته ای که داره اینه آرگومان اول فرمول آدرس مربوط به سطر هست که من توی فرمول شماره ستون رو نوشتم و آرگومان دوم شماره ستون هست که شماره سطر رو نوشتم
این عمل کار تقارن رو انجام میده

فایل ضمیمه گردید

از دوستانی که Vba کار میکنند اگه زحمت کد نویسیش رو انجام بدید و توی همین پست قرار بدید ممنون میشم
کد طوری باشه که کاربر فقط قطر بالا مثلثی رو وارد کنه که نیازی نباشه فرمول نویسی رو انجام بده
شاید بعد ماتریس هم تغییر پیدا کنه این هم مد نظر باشه

با تشکر

[abootorab]

با درود
ضمن تشکر از جناب آقای generalsamad در تکمیل آموزش و بنا به در خواست ایشان کدنویسی vba ماتریس متقارن به همراه فایل نمونه تقدیم دوستان میگردد. امیدوارم برای دوستان مفید واقع شود.

توضیح عمکرد کد:
جهت ایجاد یک ماتریس متقارن کافیه در یکی از سلولها دوبارکلیک کنید، پس از آن از شما پرسیده میشود طول قطر ماتریس چه تعداد باشد که با وارد کردن طول قطر، ماتریس متقارن خالی به ابعاد مورد نظر تولید میشود. سپس شما در هر سلول از این ماتریس که مقداری وارد کنید در سلول متقارن آن، مقدار مربوطه ایجاد خواهد شد ضمن اینکه محدودیتی در وارد کردن کدام سمت مثلثی ماتریس ندارید، یعنی در هرسمت که مقدار وارد شد در سمت متقارن مثلث مقدار شما ایجاد میشود.
همچنین با دوبارکلیک مجدد در یک سلول شما می توانید ماتریس قبلی را کاملا حذف و ماتریس جدید با ابعاد دلخواه ایجاد کنید و در صورتیکه بخواهید بدون ایجاد ماتریس جدید ماتریس قبلی را حذف کنید پس از دوبارکلیلک در یک سلول و ظاهر شدن پرسش طول قطر ماتریس، مقدار صفر را وارد و اینتر کنید.

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

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 تبدیل و آپ کردم!!!!

[s.cheraghi]

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

[Darya15]

با سلام می خواستم بدونم کاربرد این ماتریکسها چیه و کجا به درد میخوره؟

[generalsamad]

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

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