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

ايجاد قواسم عدد معين

سليم حاصبيا

بواسطه سليم حاصبيا
في منتدى الاكسيل Excel

 مشاركة

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

سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

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

‘The code for div

 

Sub div1()

Dim x As Double, i As Integer, r As Integer

Dim c As Integer, m As Integer, j As Integer

Dim lr As Integer

'lr = Cells(Rows.Count, 1).End(xlUp).Row + 1 'last row + 1

Range("a5:z100").ClearFormats

Range("a5:z100").ClearContents

r = 5

c = 2

x = Cells(3, 3).Value

if x<0 then

x=abs(x)

end if

If x Mod 2 = 0 Then

   m = x / 2

   Else

   m = x / 2 + 0.5

End If

 

For i = 1 To m

   If x Mod i = 0 Then

    Cells(r, c).Select

      With Selection.Font

        .Name = "Traditional Arabic"

        .Size = 20

        .Strikethrough = False

        .Superscript = False

        .Subscript = False

        .OutlineFont = False

        .Shadow = False

        .Underline = xlUnderlineStyleNone

        .ThemeColor = xlThemeColorLight1

        .TintAndShade = 0

        .ThemeFont = xlThemeFontNone

    End With

    Selection.Font.Bold = True

    Selection.Borders(xlDiagonalDown).LineStyle = xlNone

    Selection.Borders(xlDiagonalUp).LineStyle = xlNone

   ( With Selection.Borders(xlEdgeLeft

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Borders(xlEdgeTop)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

  ( With Selection.Borders(xlEdgeBottom

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

  (  With Selection.Borders(xlEdgeRight

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

   ( With Selection.Borders(xlInsideVertical

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

  (  With Selection.Borders(xlInsideHorizontal

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Interior

        .Pattern = xlSolid

        .PatternColorIndex = xlAutomatic

        .Color = 5287936

        .TintAndShade = 0

        .PatternTintAndShade = 0

    End With

    With Selection.Font

        .ThemeColor = xlThemeColorDark1

        .TintAndShade = 0

    End With

    With Selection

        .HorizontalAlignment = xlCenter

        .VerticalAlignment = xlBottom

        .WrapText = False

        .Orientation = 0

        .AddIndent = False

        .IndentLevel = 0

        .ShrinkToFit = False

        .ReadingOrder = xlContext

        .MergeCells = False

    End With

     Cells(r, c).Value = i

    c = c + 1

                If c > 9 Then

           c = 2

           r = r + 1

       End If

   End If

      Next i

  ( Cells(r, c).Value =abs( x

      Cells(r, c).Select

       With Selection.Font

        .Name = "Traditional Arabic"

        .Size = 20

        .Strikethrough = False

        .Superscript = False

        .Subscript = False

        .OutlineFont = False

        .Shadow = False

        .Underline = xlUnderlineStyleNone

        .ThemeColor = xlThemeColorLight1

        .TintAndShade = 0

        .ThemeFont = xlThemeFontNone

    End With

    Selection.Font.Bold = True

    Selection.Borders(xlDiagonalDown).LineStyle = xlNone

    Selection.Borders(xlDiagonalUp).LineStyle = xlNone

   ( With Selection.Borders(xlEdgeLeft

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

  (  With Selection.Borders(xlEdgeTop

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

   ( With Selection.Borders(xlEdgeBottom

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

  ( With Selection.Borders(xlEdgeRight

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

(  With Selection.Borders(xlInsideVertical

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

(   With Selection.Borders(xlInsideHorizontal

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Interior

        .Pattern = xlSolid

        .PatternColorIndex = xlAutomatic

        .Color = 5287936

        .TintAndShade = 0

        .PatternTintAndShade = 0

    End With

    With Selection.Font

        .ThemeColor = xlThemeColorDark1

        .TintAndShade = 0

    End With

    With Selection

        .HorizontalAlignment = xlCenter

        .VerticalAlignment = xlBottom

        .WrapText = False

        .Orientation = 0

        .AddIndent = False

        .IndentLevel = 0

        .ShrinkToFit = False

        .ReadingOrder = xlContext

        .MergeCells = False

    End With

     End Sub

(this is the end of (div)

رابط هذا التعليق
شارك
أبو حنــــين

أبو حنــــين

قام بنشر
قام بنشر

كود جميل جدا

بارك الله فيكم

يمكن اختصاره بالطريقة التالية

Sub div1()
Dim x As Double, i As Integer, r As Integer
Dim c As Integer, m As Integer, j As Integer
Dim lr As Integer
Range("a5:I100").ClearFormats
Range("a5:I100").ClearContents

r = 5: c = 2
x = Cells(3, 3).Value
If x < 0 Then
x = Abs(x)
End If
If x Mod 2 = 0 Then m = x / 2 Else m = x / 2 + 0.5
For i = 1 To m
   If x Mod i = 0 Then
   Cells(r, c).Value = i
    c = c + 1
   If c > 9 Then
   c = 2
   r = r + 1
   End If
   With Cells(r, c)
   .Borders.Value = 1
   .Interior.ColorIndex = 36
   End With
   End If
   Next i
Cells(r, c).Value = Abs(x)
Range("B5").Borders.Value = 1
Range("B5").ColorIndex = 36
End Sub

او هذا الكود ايضا يفي بنفس الغرض

Sub Abou_Hanine()

With Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row)
.ClearFormats: .ClearContents
End With
x = Range("A1").Value: r = 1
For i = 1 To x
If x Mod i = 0 Then
r = r + 1
Cells(r, 2) = i
End If
   With Cells(r, 2)
   .Borders.Value = 1: .Interior.ColorIndex = 36
   End With
Next
End Sub

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
  • الكاتب
قام بنشر

مشكور جداً استاذ ابو حنين

عندي سؤال اذا سمحت

كلما افتح صفحة vba ارى  في نافذة المشروع ملفين لا أدري ما هما 

الأول :(atpv.xls(ATPVBEANXLAM

الثاني  : (VBAProject(FUNRES.XLAM

سؤالي : ما الطريقة لأغلاقهما ،علماً انهما لا يؤثران على سير البرنامج ،لكنهما مزعجين، اذ ان الموديل يظهر دائماً باسميهما

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

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع

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

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

Important Information

  I accept