اذهب الي المحتوي
أوفيسنا

شرح الكود


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

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

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

 

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

 

رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

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

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

Important Information