Excel bestanden opslaan met VBA

[PatrickBunt]

Goedemiddag,

Ik ben voor mijn werk met een project bezig waarbij wij 1 keer per week bestanden willen opslaan en mailen naar onze leveranciers met een druk op de knop. Het mailen naar verschillende adressen met verschillende bestanden lukt via onderstaande code.

Sub Aanmaning1()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set sh = Sheets("Sheet1")
    
    Set OutApp = CreateObject("Outlook.Application")
    strbody = "<font face=Calibri (body)<fONT> Beste heer/mevrouw, "

    On Error Resume Next

    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeFormulas)

        'Enter the path/file names in the C:Z column in each row
        Set rng = sh.Cells(cell.Row, 1).Range("D1:Z1")

        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)

            With OutMail
                .Display
                .to = cell.Value
                .bcc = cell.Value
                .Subject = cell.Offset(0, 1).Value
         
                For Each FileCell In rng.SpecialCells(xlCellTypeFormulas)
                    If Trim(FileCell) <> "" Then
                        If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                        End If
                    End If
                Next FileCell

                .Send  'Use .Display .Send
            End With

            Set OutMail = Nothing
        End If
    Next cell

    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

Ik krijg het alleen niet voor elkaar om het bestand apart op te slaan voor iedere leverancier. Ik gebruik nu onderstaande code om het bestand via een filter apart op te slaan:
Zodra het bestand opgeslagen is als celB3 dan wil ik hem opslaan als B4, B5 etc. etc. totdat ik de laatste heb gehad. Het bereik is dynamisch.

Sub OpslaanAls()
Dim Bestandsnaam As String
Bestandsnaam = "O:\F\C\E\\" & CStr(Range("B3").value) & ".PDF"
ThisWorkbook.SaveAs Bestandsnaam, , , , True
End Sub

Hopelijk heeft iemand een idee.
Alvast bedankt voor het meedenken.

Met vriendelijke groet,

Patrick

 

[VenA]

Welk filter?

Klopt dit wel?

Bestandsnaam = "O:\F\C\E[COLOR="#FF0000"]\\[/COLOR]"

Doe er voor het gemak even een voorbeeldbestand bij de code is nogal onleesbaar en steekt qua volgorde ook niet logisch in elkaar.

 

[PatrickBunt]

Beste VenA,

Mijn excuses ik heb de verkeerde code geplaatst. In de bijlage het bestand. Met de command button "Opslaan" zou ik willen dat er een PDF wordt aangemaakt voor elk afzonderlijk levnummer. Nu doe ik dit 1 voor 1.
Bekijk bijlage Helpmij.xlsm

 

[VenA]

In de module van het formulier

Sub VenA(c01)
  c00 = "E:\Temp\"
  With Sheets("Blad1").Cells(1).CurrentRegion
    .AutoFilter 1, c01
    .ExportAsFixedFormat 0, c00 & c01 & ".pdf"
  End With
End Sub

Voor de knop 'Als pdf opslaan'

Private Sub CommandButton5_Click()
  Application.ScreenUpdating = False
  If ComboBox1.ListIndex = -1 Then
    For j = 0 To ComboBox1.ListCount - 1
      VenA ComboBox1.List(j, 0)
    Next j
   Else
    VenA ComboBox1
  End If
End Sub

 

[PatrickBunt]

Goedemorgen VenA,

Mijn excuses voor mijn late reactie. Dit werkt helemaal perfect. Mijn dank hiervoor. Zou je misschien het 1 en ander willen toelichten over de codes?
Waar bijvoorbeeld de c00 en c01 voor staan?
Nogmaals bedankt voor deze oplossing.

Patrick Bunt