mukeshdak

2020-02-28-useful-vba-code

Feb 28th, 2020
521
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1.  
  2. Public Function digitSum(x As Integer)
  3. Dim I As Integer
  4. Dim SumDigit As Integer
  5. SumDigit = 0
  6.  
  7.  
  8. For I = 1 To 10
  9.  
  10.     SumDigit = SumDigit + (x Mod 10)
  11.     x = Int(x / 10)
  12.     MsgBox "Value of " + I + " value of " + SumDigit
  13.    
  14.     If (x < 1) Then Exit Function
  15. Next I
  16.  
  17. digitSum = SumDigit
  18.  
  19. End Function
  20.  
  21.  
  22.  
  23. Sub ginti()
  24. Dim Source As Range
  25. Set Source = Selection
  26. q = Source.Text
  27. 'Source.Value = 3
  28. 'Source.Value = 4
  29.    With Source
  30.         .Value = 1
  31.         .AutoFill .Resize(q, 1), xlFillSeries
  32.     End With
  33.  
  34.  
  35. End Sub
  36.  
  37. Sub HighlightErrors()
  38.  Selection.SpecialCells(xlCellTypeFormulas, xlErrors).Select
  39.  Selection.Interior.Color = vbRed
  40. End Sub
  41.  
  42. Public Function ms(x As Single)
  43. For I = 1 To 10
  44.  
  45. x = x / 1000
  46. If (x < 1000) Then Exit For
  47. Next I
  48.  
  49. Dim munit As String
  50. If I = 1 Then munit = "Byte"
  51. If I = 2 Then munit = "Kb"
  52. If I = 3 Then munit = "Mb"
  53. If I = 4 Then munit = "Gb"
  54. If I = 5 Then munit = "Tb"
  55.  
  56. ms = x & " " & munit
  57.  
  58. End Function
  59.  
  60.  
  61. Public Function pipe_schedule(number1 As Integer, number2 As Integer)
  62.     Add = number1 + number2
  63. End Function
  64.  
  65.  
  66. Public Function checkEven(num As Integer)
  67.     If num Mod 2 = 0 Then
  68.     checkEven = True
  69.     Else
  70.     checkEven = False
  71.     End If
  72.  
  73. End Function
  74.  
  75. Public Function ISMC(size As Integer)
  76.    Select Case size
  77.       Case 75
  78.         ISMC = 6.8
  79.       Case 100
  80.          ISMC = 9.2
  81.       Case Else
  82.          ISMC = "ERROR"
  83.    End Select
  84. End Function
  85.  
  86. Function GetNumeric(CellRef As String) As Long
  87. Dim StringLength As Integer
  88. StringLength = Len(CellRef)
  89. For I = 1 To StringLength
  90. If IsNumeric(Mid(CellRef, I, 1)) Then result = result & Mid(CellRef, I, 1)
  91. Next I
  92. GetNumeric = result
  93. End Function
  94.  
  95. Sub mdInsulationCheck()
  96.     Dim Source As Range
  97.     Dim errFlag As Boolean
  98.     Dim errCount As Integer
  99.    ' Dim iCol As Long
  100.    Dim nCol As Long
  101.     Dim iRow As Long
  102.     Dim nRow As Long
  103.     Dim total As Double
  104.    
  105.     ' By default, there is no error.
  106.    errFlag = False
  107.     errCount = 0
  108.    
  109.     Set Source = Selection
  110.     nCol = Source.Columns.Count
  111.     nRow = Source.Rows.Count
  112.    
  113.     For iRow = 1 To nRow
  114.         x = Source.Rows(iRow).Columns(1).Address
  115.         x2 = Source.Rows(iRow).Columns(nCol).Address
  116.         sumx = Source.Rows(iRow).Columns(1 - 4).Address
  117.         sumx2 = Source.Rows(iRow).Columns(0).Address
  118.         Range(sumx & ":" & sumx2).Select
  119.         tempSum = WorksheetFunction.Product(Selection)
  120.        
  121.         For tempcol = 1 To nCol
  122.             If (Source.Rows(iRow).Columns(tempcol).Value = tempSum Or Source.Rows(iRow).Columns(tempcol).Value = "") Then
  123.             Else
  124.             errFlag = True
  125.             errCount = errCount + 1
  126.              Range(Source.Rows(iRow).Columns(tempcol).Address).Select
  127.              Selection.Interior.Color = RGB(255, 100, 100)
  128.              MsgBox "ERROR in " & Source.Rows(iRow).Columns(tempcol).Address
  129.            '  Exit Sub
  130.            End If
  131.         Next tempcol
  132.     Next iRow
  133.    
  134.     If errFlag = False Then
  135.         MsgBox "Calculation is OK"
  136.         Else
  137.         MsgBox CStr(errCount) + " Errors found", vbCritical, "Mar Gaye - Errors found."
  138.         End If
  139. End Sub
  140.  
  141. Sub mdSelectionSum()
  142.     Dim Source As Range
  143.     Dim nCol As Long
  144.     Dim iCol As Long
  145.     Dim iRow As Long
  146.     Dim nRow As Long
  147.     Dim total As Double
  148.    
  149.     Set Source = Selection
  150.     nCol = Source.Columns.Count
  151.     nRow = Source.Rows.Count
  152.    
  153.     For iCol = 1 To nCol
  154.         x = Source.Columns(iCol).Rows(1).Address
  155.         x2 = Source.Columns(iCol).Rows(nRow).Address
  156.         If Range(x & ":" & x2).EntireColumn.Hidden Then
  157.              MsgBox "Exiting ..... " + vbCrLf + vbCrLf + "There are hidden Columns.", vbCritical, "Danger"
  158.         End If
  159.     Next iCol
  160.    
  161.    
  162.     For iRow = 1 To nRow
  163.         x = Source.Rows(iRow).Columns(1).Address
  164.         x2 = Source.Rows(iRow).Columns(nCol).Address
  165.         Range(x & ":" & x2).Select
  166.         total = total + WorksheetFunction.Product(Selection)
  167.        
  168.         If Range(x & ":" & x2).EntireRow.Hidden Then
  169.              MsgBox "Exiting ..... " + vbCrLf + vbCrLf + "There are hidden Rows.", vbCritical, "Danger"
  170.         End If
  171.     Next iRow
  172.      
  173.     MsgBox total
  174.    
  175. End Sub
  176.  
  177. Public Function isPrime(Number As Long)
  178. Dim divisors As Integer
  179.     If (Number = 1) Then divisors = 1
  180.  
  181.  
  182.     For I = 2 To Number / 2
  183.         If Number Mod I = 0 Then
  184.             divisors = divisors + 1
  185.         End If
  186.     Next I
  187.  
  188.     isPrime = IIf(divisors > 0, False, True)
  189.  
  190. End Function
RAW Paste Data