Loop in VBA Code

[Anjas]

Hallo,

ich habe einen Excel-Code zum Erstellen von Serienbriefen über einen Command Button, der schon gut funktioniert, aber ich habe damit noch ein Problem:
Momentan wird der Code nur auf ein Word-Dokument angewandt, das sb1.docx heißt. Und nur dann wenn in Spalte A (sie heißt "Anz") die Zahl > 0 ist.

Nun soll aber je nachdem welche Zahl (1-5) in Spalte A (Anz) steht das entsprechende Word Doc (sb1 - sb5) genommen werden.

Geht das irgendwie?

Code:

Private Sub CommandButton1_Click()

Application.ScreenUpdating = False
Dim StrMMSrc As String, StrMMDoc As String, StrMMPath As String, StrName As String
Dim i As Long, j As Long
Const StrNoChr As String = """*./\:?|"
Dim wdApp As New Word.Application, wdDoc As Word.Document
wdApp.Visible = False
wdApp.DisplayAlerts = wdAlertsNone
StrMMSrc = ThisWorkbook.FullName
StrMMPath = ThisWorkbook.Path & "\"
StrMMDoc = StrMMPath & "sb1.docx"
Set wdDoc = wdApp.Documents.Open(Filename:=StrMMDoc, AddToRecentFiles:=False, ReadOnly:=True,  _
Visible:=False)
With wdDoc
 With .MailMerge
   .MainDocumentType = wdFormLetters
   .OpenDataSource Name:=StrMMSrc, ReadOnly:=True, AddToRecentFiles:=False, _
     LinkToSource:=False, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
     "Data Source=StrMMSrc;Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
     SQLStatement:="SELECT * FROM `Sheet1$` where (Anz>0)"
   For i = 1 To .DataSource.RecordCount
     .Destination = wdSendToNewDocument
     .SuppressBlankLines = True
     With .DataSource
       .FirstRecord = i
       .LastRecord = i
       .ActiveRecord = i
       If Trim(.DataFields("ID")) = "" Then Exit For
       StrName = .DataFields("ID")
     End With
     .Execute Pause:=False
     For j = 1 To Len(StrNoChr)
       StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
     Next
     StrName = Trim(StrName)
     With wdApp.ActiveDocument
       .SaveAs Filename:=StrMMPath & StrName & ".docx", FileFormat:=wdFormatXMLDocument,  _
AddToRecentFiles:=False
       .Close SaveChanges:=False
     End With
   Next i
   .MainDocumentType = wdNotAMergeDocument
 End With
 .Close SaveChanges:=False
End With
wdApp.DisplayAlerts = wdAlertsAll
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing
Application.ScreenUpdating = False
End Sub

[Flotter Feger]

Hallo,

mal sehen, ob ich es genauso hinbekomme, wie Steve ...

Verlinkst du bitte deine Anfragen in den unterschiedlichen Foren ... Danke.

[Klaus-Dieter]

Hallo,

ich habe einen Excel-Code zum Erstellen von Serienbriefen

warum willst du in Excel etwas nachbilden, was es in Word als Standardfunktion gibt?

[schauan]

Hallöchen

StrMMDoc = StrMMPath & "sb" & HierDerVerweisaAufDieZelleInApalteA & ".docx"

[Anjas]

Hallo und vielen dank für die Antwort André :)

Kannst du mir noch sagen wie ich überhaupt eine Schleife aus meinem Code mache? Ich bin dafür leider echt zu blöd...

Hintergrund ist der, dass meine Kollegen auch von meiner Arbeit profitieren sollen (es geht dabei um mehr als nur Seriebriefe, weil ich die Worddokumente mit digitalen Stempeln u. a. versehen habe und so das manuelle Abstempeln hunderter Unterlagen unnötig mache). Da diese leider keine ahnung von "Technik" und Serienbriefen haben, möchte ich Ihnen die Möglichkeit geben, einfach nur auf den Button in Excel zu klicken und der Rest passiert automatisch.

Ich habe meine Frage auch hier gepostet: https://www.ms-office-forum.net/forum/sh...p?t=357923

[Gast 123]

Hallo

probier es bitte mal so, ich konnte es nicht Testen, weiss nicht ob es klappt??  Würde mich freuen wenn ja!
Selbst aendern kannst du hier etwas:  die 1. Zeile steht jetzt auf 1, die Anzahl der Briefe betraegt 5.  Diese Zahlen kannst du selbst aendern
For k = 1 To 5   '** kann beliebig erhöht werden!  1 ist die erste Zeile in A, sonst korrigieren  (bei Text Überschrift!)

mfg  Gast 123        PS  (für die Kollegen)  ab Montag Abend bin ich in Urlaub, mache Pause im Forum ...

Code:

Option Explicit
Const StrNoChr As String = """*./\:?|"

Private Sub CommandButton1_Click()
Dim StrMMSrc As String, StrMMDoc As String, StrMMPath As String, StrName As String
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim i As Long, j As Long
Dim k As Integer, BlNr As Integer  '** Blatt Anzahl + Nummer
Application.ScreenUpdating = False
wdApp.Visible = False
wdApp.DisplayAlerts = wdAlertsNone
StrMMSrc = ThisWorkbook.FullName
StrMMPath = ThisWorkbook.Path & "\"

'Schleife beginnt ab 1.Zeile, sonst auf 2 setzen
For k = 1 To 5   '** kann beliebig erhöht werden!
If Cells(k, 1) > 0 Then
BlNr = Cells(k, 1).Value
StrMMDoc = StrMMPath & "sb" & BlNr & ".docx"
Set wdDoc = wdApp.Documents.Open(Filename:=StrMMDoc, AddToRecentFiles:=False, _
   ReadOnly:=True, Visible:=False)
With wdDoc
With .MailMerge
  .MainDocumentType = wdFormLetters
  .OpenDataSource Name:=StrMMSrc, ReadOnly:=True, AddToRecentFiles:=False, _
    LinkToSource:=False, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
    "Data Source=StrMMSrc;Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
    SQLStatement:="SELECT * FROM `Sheet1$` where (Anz>0)"
  For i = 1 To .DataSource.RecordCount
    .Destination = wdSendToNewDocument
    .SuppressBlankLines = True
    With .DataSource
      .FirstRecord = i
      .LastRecord = i
      .ActiveRecord = i
      If Trim(.DataFields("ID")) = "" Then Exit For
      StrName = .DataFields("ID")
    End With
    .Execute Pause:=False
    For j = 1 To Len(StrNoChr)
      StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
    Next
    StrName = Trim(StrName)
    With wdApp.ActiveDocument
      .SaveAs Filename:=StrMMPath & StrName & ".docx", FileFormat:= _
       wdFormatXMLDocument, AddToRecentFiles:=False
      .Close SaveChanges:=False
    End With
  Next i
  .MainDocumentType = wdNotAMergeDocument
End With
.Close SaveChanges:=False
End With
Next k

wdApp.DisplayAlerts = wdAlertsAll
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing
Application.ScreenUpdating = False
End Sub