ممكن شرح هذا الكود

[محمد الموافى]

Option Explicit
'******************************************************
'******************************************************
'  اسم ورقة البيانات
Private Const Mysh_Name As String = "DATA"
'------------------------------------------------------
'  رقم عمود البحث
Private Const MyFind_Column As Integer = 1
'------------------------------------------------------
'  ارتفاع الكنترول
Private Const iHeight As Integer = 20
'******************************************************
'******************************************************

Private Sub kh_Find(MyText As String)
Dim MyHght, MyTp
Dim Last As Integer, ii As Integer, T As Integer
'===========================================
With Me.Frame1
    MyTp = .Controls(0).Top + .Controls(0).Height + 2
    T = .Controls.Count
End With
'===========================================
With Worksheets(Mysh_Name)
    Last = .Cells(.Rows.Count, MyFind_Column).End(xlUp).Row
    For ii = 2 To Last
        If CStr(.Cells(ii, MyFind_Column)) Like IIf(Me.Check_Text.Value, "", "*") & MyText & "*" Then
            MyHght = .Rows(ii).RowHeight
            If MyHght < iHeight Then MyHght = iHeight
            kh_Add_Controls Me.Frame1, MyTp, MyHght, .Cells(ii, MyFind_Column).Row, T
            MyTp = MyTp + MyHght + 2
        End If
    Next
End With
If MyTp >= Me.Frame1.Height Then Me.Frame1.ScrollHeight = MyTp
'===========================================
End Sub

Private Sub kh_Add_Controls(MyCont As Control, MyTop, MyHeight, iRo As Integer, MyCount As Integer)
'On Error Resume Next
Dim MyTxt As Control
Dim i As Integer
For i = 1 To MyCount
    Set MyTxt = MyCont.Add("Forms.TextBox.1", Cells(iRo, i).Address, True)
    With MyTxt
        .Move MyCont.Controls(i - 1).Left, MyTop, MyCont.Controls(i - 1).Width, MyHeight
        .MultiLine = True
        '===========================================
        .ControlSource = "'" & Mysh_Name & "'!" & Range(.Name).Address
        '===========================================
    End With
    '========================================
    With Worksheets(Mysh_Name).Cells(iRo, i)
        MyTxt.TextAlign = Me.kh_TextAlign(.HorizontalAlignment)
        MyTxt.Font.Bold = .Font.Bold
        MyTxt.Font.Size = .Font.Size
        MyTxt.FontName = .Font.Name
    End With
    '========================================
Next i
'==================
Set MyTxt = Nothing
'==================
'On Error GoTo 0
End Sub

Patrive Sub kh_Remove()
On Error Resume Next
Dim MyCon As Control
Me.Frame1.ScrollHeight = 0
For Each MyCon In Me.Frame1.Controls
    If TypeName(MyCon) = "TextBox" Then
        Me.Frame1.Controls.Remove MyCon.Name
    End If
Next MyCon
On Error GoTo 0
End Sub

Private Sub Button_Find_Click()
kh_Remove
If Len(Trim(Me.TextBox_Find.Text)) Then
    kh_Find Me.TextBox_Find
End If
End Sub

Private Sub TextBox_Find_Change()
kh_Remove
End Sub
Function kh_TextAlign(MyAlign) As Integer
Dim Ag
Dim A As Integer
For A = 1 To 3
    Ag = Choose(A, -4131, -4108, -4152)
    If Ag = MyAlign Then kh_TextAlign = A: Exit Function
Next
kh_TextAlign = 1
End Function

 

[أبوبسمله]

اخى الفاضل محمد

الكود خاص بالجداول المحوريه

ضع الملف الموجود به الكود وان شاء الله نحاول نشوفلك شرح مبسط ليه

او احد اخواننا الافاضل يشرح الكود

بالتوفيق اخى

[محمد الموافى]

شكرا استاذ احمد على اهتمامك

هذا الملف حملته من المنتدى واستفدت منه كثير

لكن حتى تعم المنفعة لم افهمه

البحث بمعيارواحد.rar

[ياسر خليل أبو البراء]

أخي الكريم محمد

هل شرح الكود سيعلمك البرمجة ؟! مجرد تساؤل

لاحظت كثيراً أن الكثيرين يطلبون شرح الأكواد وللأسف كنت في اعتقادي أن شرح الأكواد سيعلم الأعضاء ويجعل منهم خبراء .. ولكن اتضح لي أنه ما بني على باطل فهو باطل ..

صحيح شرح الكود يوضح معالم الطريق ولكنه يجعل من العضو مقلد ويقتل روح الابتكار والإبداع ..

الأفضل من شرح الكود أن تقوم بتجربة الكود سطر سطر لمعرفة كيف يتم بناء السطر الكودي وكيف يتم تنفيذه

راجع موضوع الحلقات التكرارية للمصفوفات (في الفهرس الخاص بي) لتعرف كيف يمكنك تتبع الكود .. لقد تعلمت الكثير بهذه الطريقة ..

وعندما تجد سطر مستعصي عليك او لا تعرف الكلمات فيه ابدأ بالبحث عن الكلمات البرمجية فيه وحاول وتعلم وحاول وافشل وحاول إلى أن تجد نفسك في موضع تتمكن فيه من التعلم بحق

عذراً إخواني لن أقوم بشرح أكواد مرة أخرى .. فقد قمت بشرح الكثير من الأكواد ولكن بلا جدوى .. يظل العضو كما هو محلك سر ولا يتحرك قيد أنملة

أرجو ألا تأخذ كلامي بمحمل شخصي ! فقد أردت أن أفضفض عما في صدري

تقبل تحياتي

[محمد الموافى]

شاكر لحضرتك على كلماتك

فعلا عندك حق فى كل ما قلته

 

[ياسر خليل أبو البراء]

أخي العزيز محمد الموافي

والله لا أقصدك بكلامي بشخصك .. إنما قصدت أن الجميع يطلب شرح للأكواد ولا أجد تقدم من ناحيتهم وربما السبب في ضعف شرحي وضعف توصيلي للمعلومة

تقبل تحياتي

[أبوبسمله]

كلامك صحيح يا ابو البراء

ومحدش زعلان لاننا نعتبرك اخونا الكبير وكذلك معلمنا الجليل جزاك الله كل خير

والاخ محمد يعلم انك تود الصالح له بالتعلم وان شاء الله نكون عاند حسن ظنك يا ابو البراء

تقبل تحياتى ووافر الاحترام والتقدير

اخى محمد اتبع الروابط وصدقنى ستجد بها ما يسرك

انا مثلك مبتدىء بالتعليم فى vba ولولا هذه الدروس لما استطعت ان افهم اى شىء فانى اقرائها فى وقت الفراغ واعود يدى على الكتابه وليس النسخ واللصق حتى تثبت الكلمات والحروف فى راسى واه من راسى ناشفه ومخى تخين ههههههه

تقبل تحياتى ونشوفك كده علم من اعلام المنتدى باذن الله عن قريب