Loop in macro calculating twice instead of once.

[MMasiarek]

Hello

I have a problem with my macro that should find me a lowest result in the column and add 1 to it.
Macro is started from my outlook and should work on unread emails in my Inbox.
Result of Macro should be name of subfolder where my email should go.

In Outlook I have code:

Public Sub Rozdzielnik()

    Dim olNs As Outlook.NameSpace
    Dim Inbox As Outlook.MAPIFolder
    Dim Items As Outlook.Items
    Dim Item As Object
    Dim Atmt As Attachment
    Dim Filter As String
    Dim FilePath As String
    Dim AtmtName As String
    Dim i As Long
    Dim Subject As String
    
    ' Set up Outlook objects
    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = olNs.Folders("Poland e-learning").Folders("Inbox")
    
    ' Set up Excel object
    Dim xlApp As Excel.Application
    Dim xlWB As Excel.Workbook
    Dim xlWS As Excel.Worksheet
    
    ' Open Excel workbook
    Set xlApp = New Excel.Application
    Set xlWB = xlApp.Workbooks.Open("C:\Users\mmasiarek\Desktop\Rozdzielnik.xlsm", UpdateLinks:=False)
    Set xlWS = xlWB.Worksheets("Sheet1")
    
    ' Loop through each unread email in Inbox
    Filter = "[Unread] = True"
    Set Items = Inbox.Items.Restrict(Filter)
    
    For i = Items.Count To 1 Step -1
        Set Item = Items.Item(i)
        
        ' Call Excel macro to process email
        Subject = Item.Subject
        xlWB.Application.Run ("Rozdzielnik.xlsm!Sheet1.Rozdziel(" & Left(Subject, 3) & ")")
       ' xlApp.Run "Rozdziel", Left(Subject, 3)
        
        ' Get folder to move email to
        Dim folderName As String
        folderName = xlWS.Range("J6").Value
        Dim destFolder As Outlook.MAPIFolder
        Set destFolder = Inbox.Folders(folderName)
        
        ' Move email to folder
        Item.Move destFolder
    Next
    
    ' Close Excel workbook
    xlWB.Close SaveChanges:=True
    xlApp.Quit
    
    Set xlWS = Nothing
    Set xlWB = Nothing
    Set xlApp = Nothing
    
    ' Clean up Outlook objects
    Set Inbox = Nothing
    Set Items = Nothing
    Set olNs = Nothing
    
End Sub

In Excel I have macro:

Function Rozdziel(LoB As String) As String
    Dim result As String
    
    If LoB = 422 Or LoB = 402 Then
        result = AH()
        Range("J6").Value = result
    ElseIf LoB = 403 Then
        result = CAS()
        Range("J6").Value = result
    ElseIf LoB = 408 Or LoB = 423 Or LoB = 413 Or LoB = 430 Then
        result = FIN_EIL_Marine()
        Range("J6").Value = result
    ElseIf LoB = 406 Or LoB = 416 Then
        result = PROP()
        Range("J6").Value = result
    End If
    
End Function

Function AH() As String
    Dim rng As Range
    Dim sumVal As Double
    Dim minVal As Double
    Dim minRow As Integer
    Dim Prac As String
    
    ' Set the range to the two columns you want to sum and find the lowest result in
    Set rng = Range("B3:F9")
    
    ' Set the initial minimum value to a very high number
    minVal = 99999
    
    ' Loop through each row in the range and sum the values
    For Each Row In rng.Rows
        sumVal = Row.Cells(1).Value + Row.Cells(5).Value
        
        ' If the sum is lower than the current minimum, update the minimum value and the row number
        If sumVal < minVal Then
            minVal = sumVal
            minRow = Row.Row
            Prac = Row.Cells(0)
        End If
    Next Row
    ' Increase the value in column A in the row where the sum result was lowest by 1
    Range("B" & minRow).Value = Range("B" & minRow).Value + 1
    
    AH = Prac
End Function


Function CAS() As String
    Dim rng As Range
    Dim sumVal As Double
    Dim minVal As Double
    Dim minRow As Integer
    Dim Prac As String
    
    ' Set the range to the two columns you want to sum and find the lowest result in
    Set rng = Range("B3:F9")
    
    ' Set the initial minimum value to a very high number
    minVal = 99999
    
    ' Loop through each row in the range and sum the values
    For Each Row In rng.Rows
        sumVal = Row.Cells(2).Value + Row.Cells(5).Value
        
        ' If the sum is lower than the current minimum, update the minimum value and the row number
        If sumVal < minVal Then
            minVal = sumVal
            minRow = Row.Row
            Prac = Row.Cells(0)
        End If
    Next Row
    ' Increase the value in column A in the row where the sum result was lowest by 1
    Range("C" & minRow).Value = Range("C" & minRow).Value + 1
    
    CAS = Prac
End Function

Function FIN_EIL_Marine()

 Dim rng As Range
    Dim sumVal As Double
    Dim minVal As Double
    Dim minRow As Integer
    Dim Prac As String
    
    ' Set the range to the two columns you want to sum and find the lowest result in
    Set rng = Range("B3:F9")
    
    ' Set the initial minimum value to a very high number
    minVal = 99999
    
    ' Loop through each row in the range and sum the values
    For Each Row In rng.Rows
        sumVal = Row.Cells(3).Value + Row.Cells(5).Value
        
        ' If the sum is lower than the current minimum, update the minimum value and the row number
        If sumVal < minVal Then
            minVal = sumVal
            minRow = Row.Row
            Prac = Row.Cells(0)
        End If
    Next Row
    ' Increase the value in column A in the row where the sum result was lowest by 1
    Range("D" & minRow).Value = Range("D" & minRow).Value + 1
    
    FIN_EIL_Marine = Prac

End Function

Function PROP()

    Dim rng As Range
    Dim sumVal As Double
    Dim minVal As Double
    Dim minRow As Integer
    Dim Prac As String
    
    ' Set the range to the two columns you want to sum and find the lowest result in
    Set rng = Range("B3:F9")
    
    ' Set the initial minimum value to a very high number
    minVal = 99999
    
    ' Loop through each row in the range and sum the values
    For Each Row In rng.Rows
        sumVal = Row.Cells(4).Value + Row.Cells(5).Value
        
        ' If the sum is lower than the current minimum, update the minimum value and the row number
        If sumVal < minVal Then
            minVal = sumVal
            minRow = Row.Row
            Prac = Row.Cells(0)
        End If
    Next Row
    ' Increase the value in column A in the row where the sum result was lowest by 1
    Range("E" & minRow).Value = Range("E" & minRow).Value + 1
    
    PROP = Prac

End Function

Macro in excel works on taht table:

	od TSU i RR
	A&H	CAS	FIN, EIL, Marine	PROPERTY	Suma
1. Agata	1	0	0	0	1
2. Danuta	1	0	0	0	1
3. Magda	0	0	0	0	0
4. Gosia	0	0	0	0	0
5. Małgosia	0	0	0	0	0
6. Oksana	0	0	0	0	0
7. Maciej	0​	0	0	0	0
	2	0	0	0	2

The issue iam facing is: single mail with 402 in its subject should give me 1 in cell B3 and with my current codes it gives me 1 in cell B3 and 1 in cell B4
Coul anyone assist me with this problem?

 

[RoryA]

Try using:

xlWB.Application.Run "Rozdzielnik.xlsm!Sheet1.Rozdziel", Left(Subject, 3)