Thanks to visit codestin.com
Credit goes to www.scribd.com

Scribd
Upload
19 views5 pages

Final Macro

The document contains VBA code for an Excel workbook that automates tasks based on changes in specific columns. It includes a Worksheet_Change event that updates a date in column I when a value is entered in column D and triggers a macro when column A is modified. The macros perform various operations, including counting occurrences of specific values in column A and updating column M accordingly.

Uploaded by

abdelrahmanraafath
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
19 views5 pages

Final Macro

The document contains VBA code for an Excel workbook that automates tasks based on changes in specific columns. It includes a Worksheet_Change event that updates a date in column I when a value is entered in column D and triggers a macro when column A is modified. The macros perform various operations, including counting occurrences of specific values in column A and updating column M accordingly.

Uploaded by

abdelrahmanraafath
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
You are on page 1/ 5

IN SHEET 1 TYPE

Private Sub Worksheet_Change(ByVal Target As Range)


Dim cell As Range

' Check for changes in column D


If Not Intersect(Target, Me.Columns("D")) Is Nothing Then
Application.EnableEvents = False
For Each cell In Intersect(Target, Me.Columns("D"))
If cell.Value <> "" And IsEmpty(cell.Offset(0, 8).Value) Then
cell.Offset(0, 8).Value = Date
End If
Next cell
Application.EnableEvents = True
End If

' Check for changes in column A


If Not Intersect(Target, Me.Columns("A")) Is Nothing Then
' Run the AllMicro macro
Call AllMicro
End If
End Sub

-----------------------------------------------------------------------------------
-------------
IN MODULE 1 TYPE

Sub AllMicro()
' Call each of the individual macros
ClearColumnM
MicroVan850
MicroVan1000
MicroGypra10
MicroGypra20
MicroNitro
MicroZitho
End Sub

Sub MicroVan850()
Dim ws As Worksheet
Dim lastRow As Long
Dim occurrence As Integer
Dim i As Long

On Error GoTo ErrorHandler ' Add error handling

Set ws = ThisWorkbook.Sheets("Sheet1") ' Adjust sheet name if necessary


lastRow = ws.Cells(ws.Rows.count, "A").End(xlUp).Row
occurrence = 0

For i = 317 To lastRow


' Check if the cell is not empty
If Not IsEmpty(ws.Cells(i, 1).Value) Then
' Compare sorted characters and numbers, ignoring order, spaces, and
case
If AreEquivalent(ws.Cells(i, 1).Value, "Vanvilda Plus 50/850 mg") Then
occurrence = occurrence + 1
If occurrence Mod 10 = 0 Then
ws.Cells(i, 13).Value = "Micro"
End If
End If
End If
Next i

Exit Sub ' Exit the sub if no error

ErrorHandler:
MsgBox "Error: " & Err.Number & " - " & Err.Description, vbExclamation
End Sub

Sub MicroVan1000()
Dim ws As Worksheet
Dim lastRow As Long
Dim occurrence As Integer

Set ws = ThisWorkbook.Sheets("Sheet1") ' Adjust sheet name if necessary


lastRow = ws.Cells(ws.Rows.count, "A").End(xlUp).Row
occurrence = 0

For i = 547 To lastRow


' Compare sorted characters and numbers, ignoring order and spaces
If AreEquivalent(ws.Cells(i, 1).Value, "Vanvilda plus 50/1000 mg") Then
occurrence = occurrence + 1
If occurrence Mod 10 = 0 Then
ws.Cells(i, 13).Value = "Micro"
End If
End If
Next i
End Sub
Sub MicroGypra10()
Dim ws As Worksheet
Dim lastRow As Long
Dim occurrence As Integer

Set ws = ThisWorkbook.Sheets("Sheet1") ' Adjust sheet name if necessary


lastRow = ws.Cells(ws.Rows.count, "A").End(xlUp).Row
occurrence = 0

For i = 645 To lastRow


' Compare sorted characters and numbers, ignoring order and spaces
If AreEquivalent(ws.Cells(i, 1).Value, "Gypravastin 10 mg") Then
occurrence = occurrence + 1
If occurrence Mod 10 = 0 Then
ws.Cells(i, 13).Value = "Micro"
End If
End If
Next i
End Sub
Sub MicroGypra20()
Dim ws As Worksheet
Dim lastRow As Long
Dim occurrence As Integer

Set ws = ThisWorkbook.Sheets("Sheet1") ' Adjust sheet name if necessary


lastRow = ws.Cells(ws.Rows.count, "A").End(xlUp).Row
occurrence = 0
For i = 683 To lastRow
' Compare sorted characters and numbers, ignoring order and spaces
If AreEquivalent(ws.Cells(i, 1).Value, "Gypravastin 20 mg") Then
occurrence = occurrence + 1
If occurrence Mod 10 = 0 Then
ws.Cells(i, 13).Value = "Micro"
End If
End If
Next i
End Sub
Sub MicroNitro()
Dim ws As Worksheet
Dim lastRow As Long
Dim occurrence As Integer

Set ws = ThisWorkbook.Sheets("Sheet1") ' Adjust sheet name if necessary


lastRow = ws.Cells(ws.Rows.count, "A").End(xlUp).Row
occurrence = 0

For i = 372 To lastRow


' Compare sorted characters and numbers, ignoring order and spaces
If AreEquivalent(ws.Cells(i, 1).Value, "Nitrofectazole 500 mg") Then
occurrence = occurrence + 1
If occurrence Mod 10 = 0 Then
ws.Cells(i, 13).Value = "Micro"
End If
End If
Next i
End Sub
Sub MicroZitho()
Dim ws As Worksheet
Dim lastRow As Long
Dim occurrence As Integer
Dim i As Long

On Error GoTo ErrorHandler ' Add error handling

Set ws = ThisWorkbook.Sheets("Sheet1") ' Adjust sheet name if necessary


lastRow = ws.Cells(ws.Rows.count, "A").End(xlUp).Row
occurrence = 0

For i = 569 To lastRow


' Check if the cell is not empty
If Not IsEmpty(ws.Cells(i, 1).Value) Then
' Compare sorted characters and numbers, ignoring order, spaces, and
case
If AreEquivalent(ws.Cells(i, 1).Value, "Zithotrac500mg") Then
occurrence = occurrence + 1
If occurrence Mod 10 = 0 Then
ws.Cells(i, 13).Value = "Micro"
End If
End If
End If
Next i

Exit Sub ' Exit the sub if no error

ErrorHandler:
MsgBox "Error: " & Err.Number & " - " & Err.Description, vbExclamation
End Sub

Function AreEquivalent(str1 As String, str2 As String) As Boolean


' Helper function to check if two strings contain the same characters and
numbers, ignoring order, spaces, and case
Dim normalizedStr1 As String
Dim normalizedStr2 As String

' Remove spaces and convert to lowercase for case-insensitive comparison


normalizedStr1 = NormalizeString(str1)
normalizedStr2 = NormalizeString(str2)

' Compare normalized strings


AreEquivalent = (normalizedStr1 = normalizedStr2)
End Function

Function NormalizeString(inputStr As String) As String


' Helper function to normalize string by removing spaces and converting to
lowercase
NormalizeString = Replace(LCase(inputStr), " ", "")
End Function
Function SortCharactersAndNumbers(str As String) As String
' Helper function to sort characters and numbers in a string, ignoring spaces
Dim characters() As String
Dim i As Integer, j As Integer
Dim temp As String

' Remove spaces from the string


str = Replace(str, " ", "")

' Split string into characters and numbers


ReDim characters(Len(str) - 1)
For i = 1 To Len(str)
characters(i - 1) = Mid(str, i, 1)
Next i

' Sort characters and numbers using bubble sort


For i = LBound(characters) To UBound(characters) - 1
For j = i + 1 To UBound(characters)
If characters(i) > characters(j) Then
temp = characters(i)
characters(i) = characters(j)
characters(j) = temp
End If
Next j
Next i

' Combine sorted characters and numbers into a string


SortCharactersAndNumbers = Join(characters, "")
End Function

Sub ClearColumnM()
Dim ws As Worksheet
Dim lastRow As Long
Dim rng As Range

' Specify the worksheet


Set ws = ThisWorkbook.Sheets("Sheet1") ' Replace "Sheet1" with your sheet name
' Find the last used row in column M
lastRow = ws.Cells(ws.Rows.count, "M").End(xlUp).Row

' Check if there are any values in column M


If lastRow > 1 Then
' Define the range in column M to clear (excluding the header)
Set rng = ws.Range("M2:M" & lastRow)

' Clear the contents of the range


rng.ClearContents
End If
End Sub

You might also like