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

محي الدين ابو البشر

الخبراء
 عرض الملف الشخصي  عرض المشاركات

  • Posts

    877

  • تاريخ الانضمام

  • تاريخ اخر زياره

  • Days Won

    6

 نوع المحتوي 

مشاركات المكتوبه بواسطه محي الدين ابو البشر

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

    في منتدى الاكسيل Excel

    قام بنشر

    أخي الكريم عملت على الملف الأول ولم انتبه إلى تعديل الملف 

    على كل جرب هذا عسى يكون المطلوب

    Double Dlick على إي خلية في العمود E (رقم ملف الحالة) سوف يظهر التقرير الخاص ...

    Book2.xls

    • Like 3

    طريقة تحويل عمود الى جدول بشروط معينة ؟

    في منتدى الاكسيل Excel

    قام بنشر

    هذا آخر ملف لك مع الكود المنقح ويعمل جيداً 

    بعد الأخذ بعين الاعتبار الملاحظة التالية إذا سمحت لي:

    حسب العمود الأول لديك 

    دائما تبدأ بـ اسم المدرسة ثم "المدرسة" ، أرقام الكتتاب ثم "رقم الاكتتاب" ..... وفي النهاية الديانات  ثم "الديانة" هذا الكلام جميل ولا غيار عليه

    ولكن لا أدري لماذا  في بعض المدارس يختلف الترتيب  في الديانات "الديانة" ثم الديانات 

    جرب الملف المرفق مع التعديل عسى يناسبك

     

     

    تحويل عمود 4 معدل.xlsm

    • Like 1

    طريقة تحويل عمود الى جدول بشروط معينة ؟

    في منتدى الاكسيل Excel

    قام بنشر · تم تعديل بواسطه محي الدين ابو البشر

    من الصورة أعلاه يبدو أنها غير الملف الذي ارسلته في المشاركة الأولى!!!

    مع العلم أن الكود يعمل على ملفك جيداً

    أو ممكن أن نحاول استبدال السطر 

      With Columns(1)بـWith [a:a] 

     

    طريقة تحويل عمود الى جدول بشروط معينة ؟

    في منتدى الاكسيل Excel

    قام بنشر · تم تعديل بواسطه محي الدين ابو البشر

    وعليكم السلام ورحمة الله وبركاته

    ربما 

    Sub Test()
    Dim x, h
    Dim i&, c&
    Dim ar As Range
    With [a:a]
        .ClearContents
        .Interior.Color = xlNone
    End With
    h = Range("f1").Resize(, 9)
    For Each ar In Range("F1").CurrentRegion.SpecialCells(4).Areas
        x = ar.Offset(-1).Resize(ar.Count + 1, 9)
        For i = 2 To UBound(x, 2)
            If i = 2 Then Cells(3, 17).Offset(c) = IIf(i = 2, x(i - 1, 1), h(1, i - 1))
            With Cells(3, 1)
                .Offset(c + 1) = h(1, i - 1)
                .Offset(c + 1).Interior.Color = vbYellow
                .Offset(c + 2).Resize(UBound(x)) = Application.Index(x, Evaluate("row(1:" & UBound(x) & ")"), i)
            End With
            c = c + UBound(x) + 1
        Next
        Cells(3, 1).Offset(c + 1) = h(1, i - 1)
        c = c + 2
    Next
End Sub

     

    تلوين رقمين داخل شبكة أرقام

    في منتدى الاكسيل Excel

    قام بنشر · تم تعديل بواسطه محي الدين ابو البشر

    حسناً 

    يجب أخذ في عين الإعتبار وجود نفس القيمة مكررة في أكثر من خلية

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

    لكن بكل الأحوال ممكن تجربة هذا الكود 

    Sub test()
    Dim i&
    Dim x As String
    Dim r As Range
    Application.ScreenUpdating = False
    Range("A1:AI35").Interior.Color = xlNone
    For i = 14 To 15
        With Range("A1:AI35")
            Set r = .Cells.Find(Range("AL" & i), , , 1)
            x = r.Address
            Do
                r.Interior.Color = vbRed
                Set r = .Cells.FindNext(r)
            Loop Until r.Address = x
        End With
    Next
    Application.ScreenUpdating = True
End Sub
'وأيضاً لتلوين كل رقم بلون مختلف
Sub test2()
    Dim i&
    Dim x As String
    Dim r As Range
    Dim f As Boolean
    Application.ScreenUpdating = False
    Range("A1:AI35").Interior.Color = xlNone
    For i = 14 To 15
        With Range("A1:AI35")
            Set r = .Cells.Find(Range("AL" & i), , , 1)
            x = r.Address
            Do
                r.Interior.Color = IIf(f, vbRed, vbYellow)
                Set r = .Cells.FindNext(r)
            Loop Until r.Address = x
        End With
        f = True
    Next
    Application.ScreenUpdating = True
End Sub

     

    • Like 3
    • Thanks 1

    كود لتنسيق الصفوف حسب الطلب

    في منتدى الاكسيل Excel

    قام بنشر · تم تعديل بواسطه محي الدين ابو البشر

    السلام عليكم 

    حسب ما فهمت من الملف المرفق من قيبل السيد sabah2023

    هناك سوء فهم بتعبير الصفحة

    لذلك اقترح الكود التالي 

    Sub test()
    Dim  i&
       For i = 1 To  Cells(Rows.Count, 1).End(xlUp).Row Step 27
        Rows(i & ":" & i + 1).RowHeight = 30
        Rows(i + 2 & ":" & i + 26).RowHeight = 20
    Next
End Sub

     

    • Like 3
    • Thanks 1

    نقل الاسماء بدون تكرار حسب الشروط واعطاء كود لكل حالة

    في منتدى الاكسيل Excel

    قام بنشر

    عليكم السلام

    إذا كنت منفتحاً على استخدام ماكرو فإليك هذا وإلا .... 

    Sub test()
    Dim a, w
    Dim T As String
    Dim i&
    a = Sheets("aaa").Cells(1).CurrentRegion
    With CreateObject("scripting.dictionary")
        For i = 2 To UBound(a)
            T = a(i, 2) & a(i, 3) & a(i, 4)
            If Not .exists(T) Then
                .Add T, Array(.Count + 1, a(i, 2), a(i, 3), a(i, 4), a(i, 1), a(i, 1) + IIf(a(i, 1) = 1, 199, 99))
            Else
                w = .Item(T): w(5) = w(4) + 99: .Item(T) = w
            End If
        Next
        Sheets("aaa").Cells(2, 9).Resize(.Count, UBound(a, 2) + 2) = Application.Index(.items, 0, 0)
    End With
End Sub

     

    • Like 5

    محتاج كود لتلوين الخلايا فى عمود بحيث بياناته غير موجوده فى خلايا العمود الثانى

    في منتدى الاكسيل Excel

    قام بنشر 

    Sub test()
    Dim a, x
    Dim i&, ii&
  Application.ScreenUpdating = False
    a = Range(Cells(2, 6), Cells(2, 6).End(xlDown)).Cells
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(a)
            If Not .exists(a(i, 1)) Then .Add a(i, 1), a(i, 1)
        Next
        For i = 2 To Cells(1, 9).CurrentRegion.Rows.Count
        For ii = 9 To 9 + Cells(1, 9).CurrentRegion.Columns.Count - 1
            If Not .exists((Cells(i, ii).Value)) Then
                Cells(i, ii).Interior.Color = vbRed
            Else
            Cells(i, ii).Interior.Color = 16777164
            End If
        Next: Next
    End With
    Application.ScreenUpdating = True
End Sub

Sub tes2()
    Dim a, x
    x = Cells(1, 9).CurrentRegion.Columns.Count
    Dim i&, ii&
    Application.ScreenUpdating = False
    With CreateObject("scripting.dictionary")
        For i = 1 To Cells(Rows.Count, 6).End(xlUp).Row
            If Not .exists(Cells(i, 6).Value) Then .Add Cells(i, 6).Value, ""
        Next
        For i = 2 To Cells(1, 9).CurrentRegion.Rows.Count
        For ii = 9 To 9 + Cells(1, 9).CurrentRegion.Columns.Count - 1
            If Not .exists((Cells(i, ii).Value)) Then
                Cells(i, ii).Interior.Color = vbYellow
                Else
                Cells(i, ii).Interior.Color = 16777164
            End If
        Next: Next
    End With
    Application.ScreenUpdating = True
End Sub

     

    • Like 5

    طلب مساعدة

    في منتدى الاكسيل Excel

    قام بنشر

    تفضل أخي الكريم 

    Sub test()
Dim a, w, x, k
Dim i&, ii&
    a = Cells(1).CurrentRegion
    With CreateObject("scripting.dictionary")
        For i = 5 To UBound(a)
            If Not .exists(a(i, 9)) Then
                .Add a(i, 9), Array(a(i, 9), a(i, 2), a(i, 3) & "\" & a(i, 4), "SP" & a(i, 5) & " PORT " & Format(a(i, 6), "0#"), a(i, 10) & " NO -  " & Format(a(i, 7), "0#"))
            Else
                w = .Item(a(i, 9))
                x = Split(w(3), "-")
                If UBound(x) > 0 Then
               w(3) = x(0) & "- " & Format(a(i, 6), "0#")
                .Item(a(i, 9)) = w
                Else
                x(UBound(x)) = x(UBound(x)) & " -" & Format(a(i, 6), "0#")
                w(3) = Join(x)
                .Item(a(i, 9)) = w
            End If: End If
        Next
       For Each k In .keys
       Cells(5 + ii, 14).Resize(5) = Application.Transpose(.Item(k))
       ii = ii + 6
       Next
    End With
End Sub

     

    • Like 3

    محتاج كود لتلوين الخلايا فى عمود بحيث بياناته غير موجوده فى خلايا العمود الثانى

    في منتدى الاكسيل Excel

    قام بنشر · تم تعديل بواسطه محي الدين ابو البشر 

    Sub test()
    Dim a
    Dim i&
    a = Range(Cells(2, 6), Cells(2, 6).End(xlDown)).Cells
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(a)
            If Not .exists(a(i, 1)) Then .Add a(i, 1), a(i, 1)
        Next
        For i = 2 To Cells(Rows.Count, 9).End(xlUp).Row
            If Not .exists((Cells(i, 9).Value)) Then
                Cells(i, 9).Interior.Color = vbRed
            Else
            Cells(i, 9).Interior.Color = xlNone
            End If
        Next
    End With
End Sub
  ---------------------
Sub tes2()
    Dim a
    Dim i&
    With CreateObject("scripting.dictionary")
        For i = 1 To Cells(Rows.Count, 6).End(xlUp).Row
            If Not .exists(Cells(i, 6).Value) Then .Add Cells(i, 6).Value, ""
        Next
        For i = 2 To Cells(Rows.Count, 9).End(xlUp).Row
            If Not .exists((Cells(i, 9).Value)) Then
                Cells(i, 9).Interior.Color = vbYellow
                Else
                Cells(i, 9).Interior.Color = xlNone
            End If
        Next
    End With
End Sub

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

    • Like 4
×
×
  • اضف...

Important Information

  I accept