Fejl i makroen sendautomail?

Hej ekspert.

Der opstår en fejl i Filen/makroen nedenfor.

Filen/Makroen ”sendautomail” henter, som eks., de filer for uge 45 til 52 hvor der i ”B8” er skrevet en værdi.

Fejlen opstår i firmaet ”SIM”, hvor der er skrevet en værdi i ”B8” for alle ugerne 45-52, her hentes filer med navnet SIM i uge 45, 46, 49, 50, 51 og 52, men i uge 47 og 48 springer den over til firmaet Simonsen og henter de to filer hvor der er skrevet værdier i ”B8” og vedhæfter
dem Mailen til SIM.

Nu mangler SIM filerne for uge 47 og 48 og Simonsen får ingen filer for uge 47 og 48, selv om de opfylder betingelserne.

Er der nogen der har et bud på fejlen.



Function CreateMail(astrRecip As Variant, _
                  astrCCpers As Variant, _
                  strSubject As String, _
                  strMessage As String, _
                  Optional astrAttachments As Variant) As Boolean

  Dim olApp                As Outlook.Application
  Dim objNewMail            As Outlook.MailItem
  Dim varAttach            As Variant
  Dim blnResolveSuccess    As Boolean

  On Error GoTo CreateMail_Err

  Set olApp = New Outlook.Application
      Set myNameSpace = olApp.GetNamespace("MAPI")
  Set myFolder = myNameSpace.GetDefaultFolder(olFolderDrafts)
      Set objNewMail = olApp.CreateItem(olMailItem)

  With objNewMail
      .Recipients.Add (astrRecip)
     
      If Not astrCCpers = "" Then
        Set test = .Recipients.Add(astrCCpers)
        test.Type = olCC
      End If
     
      For Each varAttach In astrAttachments
        If Not IsEmpty(varAttach) Then .Attachments.Add varAttach
      Next varAttach
      .Subject = strSubject
      .Body = strMessage
   
      .Save    '.Send
     
  End With

  CreateMail = True

CreateMail_End:
  Exit Function
CreateMail_Err:
  CreateMail = False
 
  Resume CreateMail_End
End Function

Sub BatchProcess()
Dim FS As FileSearch
Dim FilePath As String, FilePathStart As String
Dim i As Integer, j As Integer
Dim v As Variant
Dim C As Range, rgFCell As Range
Dim Firmaer As Range
Dim Cell2Get
Const sheet As String = "Opgørelse"

With ThisWorkbook.Sheets(1)
    Set Firmaer = .Range("A2:A" & .Range("A65536").End(xlUp).Row)
End With
FilePathStart = ThisWorkbook.path
Cell2Get = "B8"
Application.ScreenUpdating = False
Set FS = Application.FileSearch
For Each C In Range("F1:M1")
    With FS
        .NewSearch                                                         
        .LookIn = FilePathStart & "\" & C & "\"
        .FileType = msoFileTypeExcelWorkbooks           
        .SearchSubFolders = False
        .Execute
        If .FoundFiles.Count = 0 Then GoTo Igen
        For i = 1 To .FoundFiles.Count
            v = Split(.FoundFiles(i), Application.PathSeparator)
            FilePath = Left(.FoundFiles(i), InStrRev(.FoundFiles(i), Application.PathSeparator))
            If GetValue(FilePath, v(UBound(v)), sheet, Cell2Get) > 0 Then
                For Each rgFCell In Firmaer
                    If UCase(v(UBound(v))) Like "??" & UCase(rgFCell) & "*" Then    '*****ændret
                        Cells(rgFCell.Row, C.Column) = .FoundFiles(i)
                        Exit For
                    End If
                Next
            End If
        Next i
    End With
Igen:
Next
End Sub


Private Function GetValue(path, file, sheet, range_ref)
Dim arg As String
arg = "'" & path & "[" & file & "]" & sheet & "'!" & Range(range_ref).Range("A1").Address(, , xlR1C1)
GetValue = ExecuteExcel4Macro(arg)
End Function


Sub Main()
Dim vfiler
Dim x As Boolean
Dim C As Range
BatchProcess
For Each C In Range("B2:B" & Range("B65536").End(xlUp).Row)
   
    vfiler = Range("F" & C.Row, "O" & C.Row)
   
    x = CreateMail(C.Value, C.Offset(0, 1), C.Offset(0, 2), C.Offset(0, 3), vfiler) 'ændret
   
    If x = False Then MsgBox C.Value & "  ikke oprettet"
Next
End Sub