اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

الردود الموصى بها

قام بنشر

السلام عليكم اخوتي الكرام

ارجو لو تكرمتم شرح الكود هذا

 

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, Range("U10")) Is Nothing Then
    Select Case Range("U10").Value
    Case Is = Range("W15").Value
    copy_basic
    copy_custom (15)
    Case Is = Range("W16").Value
    copy_basic
    copy_custom (16)
    Case Is = Range("W17").Value
    copy_basic
    copy_custom (17)
    Case Is = Range("W18").Value
    copy_basic
    copy_custom (18)
    Case Is = Range("W19").Value
    copy_basic
    copy_custom (19)
    Case Is = Range("W20").Value
    copy_basic
    copy_custom (20)
    Case Is = Range("W21").Value
    copy_basic
    copy_custom (21)
    Case Is = Range("W22").Value
    copy_basic
    copy_custom (22)
    Case Is = Range("W23").Value
    copy_basic
    copy_custom (23)
    Case Is = Range("W24").Value
    copy_basic
    copy_custom (24)
    Case Is = Range("W25").Value
    copy_basic
    copy_custom (25)
    Case Is = Range("W26").Value
    copy_basic
    copy_custom (26)
    Case Is = Range("W27").Value
    copy_basic
    copy_custom (27)
    Case Is = Range("W28").Value
    copy_basic
    copy_custom (28)
    Case Is = Range("W29").Value
    copy_basic
    copy_custom (29)
    Case Is = Range("W30").Value
    copy_basic
    copy_custom (30)
    Case Is = Range("W31").Value
    copy_basic
    copy_custom (31)
    Case Is = Range("W32").Value
    copy_basic
    copy_custom (32)
    Case Is = Range("W33").Value
    copy_basic
    copy_custom (33)
    Case Is = Range("W34").Value
    copy_basic
    copy_custom (34)
    Case Else
    MsgBox "البرنامج غير محدد سلفا", vbCritical
    End Select
ElseIf Not Intersect(Target, Range("A10:A12")) Is Nothing Then
    If Range("A10") = 0 Then
    Range("A15,A17,A19,A21,A23,A25,A27,A29,A31,A33").EntireRow.Hidden = True
    Else
    Range("A15,A17,A19,A21,A23,A25,A27,A29,A31,A33").EntireRow.Hidden = False
    End If
    If Range("A12") = 0 Then
    Range("A16,A18,A20,A22,A24,A26,A28,A30,A32,A34").EntireRow.Hidden = True
    Else
    Range("A16,A18,A20,A22,A24,A26,A28,A30,A32,A34").EntireRow.Hidden = False
    End If
Else
If Me.[T1] Then Exit Sub
    If Not Application.Intersect(Target, Range("myrange")) Is Nothing Then
        Application.EnableEvents = False
        Application.Undo
        Application.EnableEvents = True
    End If


Exit Sub
End If

End Sub

Sub copy_basic()
Set Sh2 = Sheet2
Sh2.Range("C11").Value = Range("B3").Value
Sh2.Range("C12").Value = Range("AH98").Value
Sh2.Range("H12").Value = Range("K3").Value
Sh2.Range("J14").Value = Range("L7").Value
Sh2.Range("J16").Value = Range("L10").Value
Sh2.Range("J18").Value = Range("B7").Value
Sh2.Range("J20").Value = Range("B5").Value
Sh2.Range("J22").Value = Range("J5").Value
Sh2.Range("J50").Value = Range("U7").Value
Sh2.Range("J52").Value = Range("U3").Value
Sh2.Range("J54").Value = Range("U5").Value
Sh2.Range("J56").Value = Range("U12").Value
Sh2.Range("L18").Value = Range("B8").Value
Sh2.Range("O17").Value = Range("M5").Value
Sh2.Range("O21").Value = Range("R5").Value
Sh2.Range("O26").Value = Range("S3").Value
Sh2.Range("p14").Value = Range("p7").Value
End Sub

Sub copy_custom(nos As Integer)
Set Sh2 = Sheet2
Sh2.Range("J26").Value = Range("A" & nos).Value
Sh2.Range("J28").Value = Range("B" & nos).Value
Sh2.Range("J30").Value = Range("J" & nos).Value
Sh2.Range("J32").Value = Range("K" & nos).Value
Sh2.Range("J34").Value = Range("G" & nos).Value
Sh2.Range("J36").Value = Range("R" & nos).Value
Sh2.Range("J38").Value = Range("I" & nos).Value
Sh2.Range("J40").Value = Range("O" & nos).Value
Sh2.Range("J42").Value = Range("L" & nos).Value
Sh2.Range("J44").Value = Range("D" & nos).Value
End Sub

 

انشئ حساب جديد او قم بتسجيل دخولك لتتمكن من اضافه تعليق جديد

يجب ان تكون عضوا لدينا لتتمكن من التعليق

انشئ حساب جديد

سجل حسابك الجديد لدينا في الموقع بمنتهي السهوله .

سجل حساب جديد

تسجيل دخول

هل تمتلك حساب بالفعل ؟ سجل دخولك من هنا.

سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information