مساعدة في دمج مجموعة اكود

[محمد الورفلي1]

اريد جمع هذان الكودين

Private Sub ShockwaveFlash1_OnReadyStateChange(ByVal newState As Long)

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
ActiveSheet.Unprotect ""
If Not Intersect(Target, Range("C18:C2014")) Is Nothing Then
        Select Case Target
            Case 1
                Target = "اولي ابتدائي"
            Case 2
                Target = "ثانية ابتدائي"
            Case 3
                Target = "ثالثة ابتدائي"
            Case 4
                Target = "الصف الرابع"
            Case 5
                Target = "الصف الخامس"
            Case 6
                Target = "الصف السادس"
            Case 7
                Target = "الصف السابع"
            Case 8
                Target = "الصف الثامن"
            Case 9
                Target = "الصف التاسع"

        End Select
    End If
    If Not Intersect(Target, Range("d18:d2014")) Is Nothing Then
        Select Case Target
            Case "ك"
                Target = "ذكر"
            Case "ن"
                Target = "انثى"
            

        End Select
    End If


Application.ScreenUpdating = False
If Target.Column = 4 Or Target.Column > 8 Then GoTo 1
LR = Cells(Rows.Count, 2).End(xlUp).Row
If Range("B" & LR) = "" Or Range("C" & LR) = "" Or Range("d" & LR) = "" _
Or Range("e" & LR) = "" Then GoTo 1

    Range("b18:e" & LR).Select
    Selection.Sort Key1:=Range("b18"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
'''''''''''''''''''''''''''''''''''''''''''''''
       With Range("b20:b" & LR + 3)
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
      .Font.Size = 18
      .Font.Bold = True
      End With
     
''''''''''''''''''''''''''''''''''''''''''''
      With Range("b20:b" & LR + 3)
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
      .Font.Size = 18
      .Font.Bold = True
      End With
      Range("b" & LR + 5).Select
1:
Application.ScreenUpdating = True
ActiveSheet.Protect ""

End Sub

  الكود رقم 2  الذي اريد دمجه مع الاكواد المدمجة السابقة

'Sub tor()
'Dim rg As Range
'Range("C18:C2014").ClearFormats
'For Each x In Range("C18:C2014")
    'If x.Value = [h10] Then
            'If rg Is Nothing Then
            'Set rg = x
            'Else
            'Set rg = Union(rg, x)
            'End If
    'End If
   
'Next
'If rg Is Nothing Then Exit Sub
'rg.Select
  'With Selection.Interior
        '.Pattern = xlSolid
        '.PatternColorIndex = xlAutomatic
        '.Color = 10092441
        
    'End With
'End Sub

'Private Sub Worksheet_Change(ByVal Target As Range)
'If Not Intersect(Target, Range("h10")) Is Nothing Then
'tor
'End If
'End Sub

جمع الكود.rar

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

جرب التالي .. قم بالتجربة لأني لم أجربه

Private Sub ShockwaveFlash1_OnReadyStateChange(ByVal newState As Long)

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
    Dim rg As Range
    ActiveSheet.Unprotect ""
    
    If Not Intersect(Target, Range("h10")) Is Nothing Then
        Range("C18:C2014").ClearFormats
            For Each x In Range("C18:C2014")
                If x.Value = [h10] Then
                        If rg Is Nothing Then
                        Set rg = x
                        Else
                        Set rg = Union(rg, x)
                        End If
                End If
               
            Next
        If rg Is Nothing Then Exit Sub
        rg.Select
          With Selection.Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 10092441
                
            End With
    End If
    
    If Not Intersect(Target, Range("C18:C2014")) Is Nothing Then
            Select Case Target
                Case 1
                    Target = "اولي ابتدائي"
                Case 2
                    Target = "ثانية ابتدائي"
                Case 3
                    Target = "ثالثة ابتدائي"
                Case 4
                    Target = "الصف الرابع"
                Case 5
                    Target = "الصف الخامس"
                Case 6
                    Target = "الصف السادس"
                Case 7
                    Target = "الصف السابع"
                Case 8
                    Target = "الصف الثامن"
                Case 9
                    Target = "الصف التاسع"
    
            End Select
        End If
        
    If Not Intersect(Target, Range("d18:d2014")) Is Nothing Then
    On Error Resume Next
        Select Case Target
            Case "ك"
                Target = "ذكر"
            Case "ن"
                Target = "انثى"
        End Select
    End If
    
    
    If Target.Column = 4 Or Target.Column > 8 Then GoTo 1
    LR = Cells(Rows.Count, 2).End(xlUp).Row
    If Range("B" & LR) = "" Or Range("C" & LR) = "" Or Range("d" & LR) = "" _
    Or Range("e" & LR) = "" Then GoTo 1
    
        Range("b18:e" & LR).Select
        Selection.Sort Key1:=Range("b18"), Order1:=xlAscending, Header:=xlNo, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal
    '''''''''''''''''''''''''''''''''''''''''''''''
           With Range("b20:b" & LR + 3)
          .HorizontalAlignment = xlCenter
          .VerticalAlignment = xlCenter
          .Font.Size = 18
          .Font.Bold = True
          End With
         
    ''''''''''''''''''''''''''''''''''''''''''''
          With Range("b20:b" & LR + 3)
          .HorizontalAlignment = xlCenter
          .VerticalAlignment = xlCenter
          .Font.Size = 18
          .Font.Bold = True
          End With
          Range("b" & LR + 5).Select
1:
ActiveSheet.Protect ""
Application.ScreenUpdating = True


End Sub

تم تعديل أكتوبر 25, 2014 بواسطه YasserKhalil

[محمد الورفلي1]

الاخ ياسر ظهرت لي هذه الرسالة

 

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

أخي الحبيب إذا كنت تنوي التعامل مع الأكواد فقم بإلغاء دمج الخلايا واستبدل هذا الدمج بالتوسيط خلال مجموعو خلايا عن طريق تحديد مجموعة الخلايا التي تريد توسيط النص بها ثم كليك يمين وتنسيق خلايا ثم التبويب Alignment ثم من القائمة المنسدلة الأولى اختر Center Across Seelction.

[محمد الورفلي1]

شكراً اخي يلسر

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

شكراً اخي يلسر

عفوا يا خلزمي

[محمد الورفلي1]

اسف على الخطاء في كتابة اسمك  فقط من الاستعجال اخي ياسر

 

بعد اذنك

 

فقط جربت فك دمج الخلاياء بدون فائدة نفس الرسالة ممكن تجربة وتصلح لي الخطاء لو سمحت

تم تعديل أكتوبر 25, 2014 بواسطه محمد الخازمي