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

[سليم حاصبيا]

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

‘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

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

[أبو حنــــين]

السلام عليكم

من القائمة أدوات  -------->  وظائف اضافيية

تظهر لك نافذف تحتوي على بعض الوضائف الاضافية

امسح علامة ( صح ) عنها ثم موافق