Help with vba

[VLynn]

Hello,

I'm looking for a macro that I can run and it will give me the common factors of a set of numbers between 10 and 80. Where I work, I deal with numbers a lot and I'm trying to find and easier way to find common factors. For example: I have 5 different number that are 2400, 1400, 1200, 1000, and 200. I need to find the common factors between 10 and 80 of these numbers. If I have a set of number that do not have a common factor between 10 and 80 I need the output as something like "None" or something similar. Below is the macro I have now that I found somewhere a couple weeks ago. But I would like to enter more then one number and for it to filter the output between 10 and 80.

--------------------------------------------------------------

Sub Common_Factors()
      Dim Count As Integer
      Dim NumToFactor As Single 'Integer limits to < 32768
      Dim Factor As Single
      Dim y As Single
      Dim IntCheck As Single
   
      Count = 0
      Do
         NumToFactor = _
            Application.InputBox(Prompt:="Type integer", Type:=1)

         'Force entry of integers greater than 0.
         IntCheck = NumToFactor - Int(NumToFactor)
         If NumToFactor = 0 Then
            Exit Sub
            'Cancel is 0 -- allow Cancel.
         ElseIf NumToFactor < 1 Then
            MsgBox "Please enter an integer greater than zero."
         ElseIf IntCheck > 0 Then
            MsgBox "Please enter an integer -- no decimals."
         End If

         'Loop until entry of integer greater than 0.
      Loop While NumToFactor <= 0 Or IntCheck > 0

      For y = 1 To NumToFactor
         'Put message in status bar indicating the integer being checked.
         Application.StatusBar = "Checking " & y
         Factor = NumToFactor Mod y

         'Determine if the result of division with Mod is without _
             remainder and thus a "factor".
         If Factor = 0 Then
            'Enter the factor into a column starting with the active cell.
            ActiveCell.Offset(Count, 0).Value = y
            'Increase the amount to offset for next value.
            Count = Count + 1
         End If
      Next

      'Restore Status Bar.
      Application.StatusBar = "Ready"
   End Sub

---------------------------------------------------

Thanks,
Lynn

[mancubus]

welcome to the forum. please use code tags when posting your code. (see my signature.)

uploading your workbook will help resolve your requirement. (see my signature.)


test with a blank worksheet

Sub vbax_57757_common_factors()

    Dim NumbersCF
    Dim LN As Long, UN As Long, j As Long
    Dim tmpArr
    
    LN = 10
    UN = 80
    
    NumbersCF = Array(2400, 1400, 1200, 1000, 200, 3, 8, 12)
    
    For j = LBound(NumbersCF) To UBound(NumbersCF)
        tmpArr = FactorsOfANumber(CDbl(NumbersCF(j)), LN, UN)
        If UBound(tmpArr) = -1 Then
            Cells(1, j + 1).Value = "None"
        Else
            Cells(1, j + 1).Resize(UBound(tmpArr) + 1).Value = Application.Transpose(tmpArr)
        End If
    Next j

End Sub

uses following UDF

Function FactorsOfANumber(NumToChk As Double, LowerNum As Long, UpperNum As Long) As Variant
'vbax_57757

    Dim Num As Long
    Dim FactorsList As String
    
    For Num = LowerNum To UpperNum
        If Int(NumToChk / Num) = (NumToChk / Num) Then
            FactorsList = FactorsList & "," & Num
        End If
    Next Num
    
    FactorsOfANumber = Split(Mid(FactorsList, 2), ",")
    
End Function

[SamT]

Do you want every factor or just the Primes? ie: 2400 if factorable by 1, 2, 3, 4, 5, 6, 8, 10, 12, 15, 16. . . . 2400

If only the Primes are needed, the Factors are 2, 3, and 5.

Note that the Prime Factors of all numbers will be smaller the the Square root of the number. The SqRt of 2400 is less than 50, so the only possible Prime factors of all numbers less than 2400 are 2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, and 47.

[SamT]

Public Function First100Primes() As Variant
'An Array of arrays. (10 each of 10 values)

Dim FactorialsTo_960, FactorialsTo_5238, FactorialsTo_16128, FactorialsTo_32040
Dim FactorialsTo_54288, FactorialsTo_80088, FactorialsTo_124608, FactorialsTo_218088
Dim FactorialsTo_292680, FactorialsTo_299208

FactorialsTo_960 = Array(2, 3, 5, 7, 11, 13, 17, 19, 23, 29)                   'to 960
FactorialsTo_5238 = Array(31, 37, 41, 43, 47, 53, 59, 61, 67, 71)              'to 5,328
FactorialsTo_16128 = Array(73, 79, 83, 89, 97, 101, 103, 107, 109, 113)        'to 16,128
FactorialsTo_32040 = Array(127, 131, 137, 139, 149, 151, 157, 163, 167, 173)   'to 32,040
FactorialsTo_54288 = Array(179, 181, 191, 193, 197, 199, 211, 223, 227, 229)   'to 54,288 '181 factors all Excel Integers
FactorialsTo_80088 = Array(233, 239, 241, 251, 257, 263, 269, 271, 277, 281)   'to 80,088
FactorialsTo_124608 = Array(283, 293, 307, 311, 313, 317, 331, 337, 347, 349)  'to 124,608
FactorialsTo_218088 = Array(353, 359, 367, 373, 379, 383, 389, 397, 401, 409)  'to 218,088
FactorialsTo_292680 = Array(419, 421, 431, 433, 439, 443, 449, 457, 461, 463)  'to 292,680
FactorialsTo_299208 = Array(467, 479, 487, 491, 499, 503, 509, 521, 523, 541)  'to 299,208

First100Primes = Array(FactorialsTo_960, FactorialsTo_5238, FactorialsTo_16128, FactorialsTo_32040, _
                       FactorialsTo_54288, FactorialsTo_80088, FactorialsTo_124608, FactorialsTo_218088, _
                       FactorialsTo_292680, FactorialsTo_299208)
End Function

Sub Example_Usage_First100Primes()
Dim x, y
x = First100Primes

y = x(0)
MsgBox y(0)

y = x(9)
MsgBox y(9)
End Sub

The first 1000 Prime Numbers will factor a little over the first 62,000,000 integers.

[VLynn]

Hi mancubus,

Sorry, I should have read about uploading the attachment and posting the code first. Thank you for your code above, I'm not real good with vba but trying to learn. I love learning about coding! But anyways, I tried the code above and it automatically puts in the factors of 2400, 1400, 1200, 1000, and 200. I do like the LowerNum to UpperNum, this is what I was looking for to narrow the output down to between 10 and 80. But my numbers change with each packet that I get. I attached my workbook that I was working on. I would like to add your LowerNum to UpperNum function like you have it above between, 10 and 80. But I would like to be able to put more than one number in the box when I run the macro. Right now, when I run the macro a box pops up and I can only add one number to the box. I usually have about 4 to 5 sets of numbers per packet and numbers change from one packet to another. I also need it to filter out the common factors of those numbers. If there is no common factor then the output be something like "None". I work in a cutting factory for garments so I have to figure out how many ply to cut material at, with each packet, to get the best yield to save on material.

Thanks again for all your help

Lynn

[VLynn]

Hi SamT,

I need all factors of a set of numbers but only between 10 and 80. Like say if I was using 400... the factors I would need is 10, 16, 20, 25, 40, 50, and 80. I usually have around 4 to 5 different numbers in a packet so I would need the common factors of those sets of numbers. Thanks for the code above, I just logged on so I will check yours out too.

Thanks,
Lynn

[SamT]

This requires you to put all the numbers in the group in Row 1 of any worksheet in this workbook, then run the macro "FindCommonFactors." the results will be shown as noted on sheet 1. You can add sheets if you wish. The macro always runs against the ActiveSheet.

Here's the code

Sub FindCommonFactors()

Const SmallestFactor As Long = 10
Const LargestFactor As Long = 80

Dim i As Long
Dim f As Long
Dim SmallestNumber As Long
Dim NumberGroup As Range
Dim CommonFactors As New Collection
Dim Results As Range

With ActiveSheet
  Set NumberGroup = Range(.Range("A1"), .Cells(1, Columns.Count).End(xlToLeft))
   
 SmallestNumber = WorksheetFunction.Min(Array(NumberGroup))
    
  For f = SmallestFactor To LargestFactor
    If SmallestNumber Mod f = 0 Then CommonFactors.Add f, CStr(f)
  Next
  
  For i = 1 To NumberGroup.Count
    For f = CommonFactors.Count To 1 Step -1
      If NumberGroup(i) Mod CommonFactors(f) <> 0 Then CommonFactors.Remove (f)
      If CommonFactors.Count = 0 Then GoTo NoneFound
    Next
  Next
  
  Set Results = .Range("B3").Resize(CommonFactors.Count)
  For f = 1 To CommonFactors.Count
    Results(f) = CommonFactors(f)
  Next


Exit Sub
NoneFound:
.Range("B3") = "No Common Factors Found"
End With
End Sub

Since you might want to change the Fator spread from time to time, just change the valuse of

Const SmallestFactor As Long = 10
Const LargestFactor As Long = 80

[VLynn]

It works perfect thank you so much. One question though... when I put two number in that do not have a common factor it gives me these errors:

Capture1.JPG

Capture.JPG



Is there something else I need to do?

Thanks,
Lynn

This requires you to put all the numbers in the group in Row 1 of any worksheet in this workbook, then run the macro "FindCommonFactors." the results will be shown as noted on sheet 1. You can add sheets if you wish. The macro always runs against the ActiveSheet.

Here's the code

Sub FindCommonFactors()

Const SmallestFactor As Long = 10
Const LargestFactor As Long = 80

Dim i As Long
Dim f As Long
Dim SmallestNumber As Long
Dim NumberGroup As Range
Dim CommonFactors As New Collection
Dim Results As Range

With ActiveSheet
  Set NumberGroup = Range(.Range("A1"), .Cells(1, Columns.Count).End(xlToLeft))
   
 SmallestNumber = WorksheetFunction.Min(Array(NumberGroup))
    
  For f = SmallestFactor To LargestFactor
    If SmallestNumber Mod f = 0 Then CommonFactors.Add f, CStr(f)
  Next
  
  For i = 1 To NumberGroup.Count
    For f = CommonFactors.Count To 1 Step -1
      If NumberGroup(i) Mod CommonFactors(f) <> 0 Then CommonFactors.Remove (f)
      If CommonFactors.Count = 0 Then GoTo NoneFound
    Next
  Next
  
  Set Results = .Range("B3").Resize(CommonFactors.Count)
  For f = 1 To CommonFactors.Count
    Results(f) = CommonFactors(f)
  Next


Exit Sub
NoneFound:
.Range("B3") = "No Common Factors Found"
End With
End Sub

Since you might want to change the Fator spread from time to time, just change the valuse of

Const SmallestFactor As Long = 10
Const LargestFactor As Long = 80

[Aussiebear]

It works perfect thank you so much. One question though... when I put two number in that do not have a common factor

Sorry but I don't understand this as every whole number has at least one common factor. If you are meaning that the common factor does not fit within the defined range then we will simply need to add an error checking function to return a msg "No Factors within defined range"

[VLynn]

Sorry, I guess I should have explained better. I was meaning, such as 97 and 89, the only common factor is 1 so this is not between 10 and 80. What do I have to do to have it to return the message "No Factors within defined range. So yeah I mean that the common factor does not fit within the defined range.

Thanks

Sorry but I don't understand this as every whole number has at least one common factor. If you are meaning that the common factor does not fit within the defined range then we will simply need to add an error checking function to return a msg "No Factors within defined range"

[SamT]

add an If...Then...Else here

Set Results = .Range("B3").Resize(CommonFactors.Count)

If CommonFactors.Count > 1 Then 
Set Results = .Range("B3")
Else
Set Results = .Range("B3").Resize(CommonFactors.Count) 
End If

And you might as well add a line here

Set NumberGroup = Range(.Range("A1"), .Cells(1, Columns.Count).End(xlToLeft))

Range(.Range("B3"), .Range("B3").End(xlDown)).ClearContents        
Set NumberGroup = Range(.Range("A1"), .Cells(1, Columns.Count).End(xlToLeft))

There is a bug in the code that you can avoid. Do NOT put a number smaller than SmallestFactor, (10 at this time,) in Cell A1. There is more to the bug than that, but that will prevent the bug from triggering.

[SamT]

Try this one. I fixed that bug.