.dot aus Excel ansteuern
15.12.2007 10:38:00
Wolfgang
mit nachfolgendem Code wird das aktive Tabellenblatt gefiltert und die gefilterten Daten in eine neue Tabelle geschrieben "Basis". Das Tabellenblatt "Basis" wird in ein Verzeichnis gespeichert, welches weiter vier Dokumentenvorlagen enthält (Einladung, Rückantwort, Ergänzungshinweise, Programm). Bislang gehe ich direkt in das Verzeichnis und doppelklicke die .dot, um dann Serienbriefe zu drucken. Wäre denkbar, dass das direkt aus Excel geschehen kann?; Der Filter wird gesetzt, "Basis" wird ohne Nachfrage direkt i.d. vorgegebene Verzeichnis gespeichert bzw. überschrieben und über ein UF (o.ä) würden dann die .dot angezeigt werden, um dann die jeweilige Vorlage auszuwählen die per Seriendruck gedruckt werden soll ("Basis" ist den .dot als Datenquelle zugewiesen). - Wird dann der Vordruck Einladung gewählt, wäre schön wenn eine zusätzliche "Maske" erscheint, in die dann das Einladungsdatum, Uhrzeit und Raum eingetragen werden können und ggfs. noch sonstige Hinweise (Siehe Code - Spalten V:AA1), so dass die in "Basis" gespeicherten Datensätze noch diese Angaben hierüber erhalten.
Wäre für Rückmeldungen und Hinweise über Lösungsmöglichkeiten,-ansätze sehr dankbar.
Herzliche Grüße
Wolfgang
Sub Serienbrief()
'Bildschirmflackern aus
' Application.ScreenUpdating = False
' Variablendeklaration
Dim intCounter As Integer
Dim shSource As Worksheet
Dim lngRow As Long
Dim wb As Workbook
Dim sport As String
Dim fd As FileDialog
Dim vrtSelectedItem As Variant
'neue Tabelle für gefiltere Datensätze anlegen
' Objektvariable für aktives Blatt festlegen
Set shSource = ActiveSheet
' Schleife über 14 TextBoxes
For intCounter = 1 To 14
'Wenn eine Auswahl erfolgte, dann
If Controls("cbbKriterium" & intCounter).ListIndex -1 Then
'Kriterium festlegen
If intCounter = 3 Then
Range("A1").AutoFilter Field:=intCounter, _
Criteria1:=CDate(Controls("cbbKriterium" & intCounter).Value)
Else
Range("A1").AutoFilter Field:=intCounter, _
Criteria1:=Controls("cbbKriterium" & intCounter).Value
End If
End If
Next intCounter
' Alle sichtbaren Zellen kopieren
Range("A1").CurrentRegion.Copy
' Neues Arbeitsblatt hinzufügen
Set wb = Workbooks.Add(1)
ActiveSheet.Paste
' Autofilter ausschalten
shSource.Range("A1").AutoFilter
' Kopiermodus ausschaltern
Application.CutCopyMode = False
' Zwischenspeicher einfügen
' Zelle A1 auswählen
Range("A1").Select
wb.Activate
Rows("1:1").Select
Selection.Delete Shift:=xlUp
With ActiveSheet.Range("V1")
.Value = "Infodatum"
.Font.Size = 10
.Font.Bold = True
End With
With ActiveSheet.Range("W1")
.Value = "Infouhrzeit"
.Font.Size = 10
.Font.Bold = True
End With
With ActiveSheet.Range("X1")
.Value = "Inforaum"
.Font.Size = 10
.Font.Bold = True
End With
With ActiveSheet.Range("Y1")
.Value = "sonstig1"
.Font.Size = 10
.Font.Bold = True
End With
With ActiveSheet.Range("Z1")
.Value = "sonstig2"
.Font.Size = 10
.Font.Bold = True
End With
With ActiveSheet.Range("AA1")
.Value = "sonstig3"
.Font.Size = 10
.Font.Bold = True
End With
With ActiveSheet.Range("S:S")
.NumberFormat = "dd. mmmm yyyy"
End With
With ActiveSheet.Range("T:T")
.NumberFormat = "dd. mmmm yyyy"
End With
With ActiveSheet.Range("V:V")
.NumberFormat = "dd. mmmm yyyy"
End With
With ActiveSheet.Range("W:W")
.NumberFormat = "hh:mm"
End With
' Dialog beenden
Unload Me
Unload frmBasisdaten
MsgBox ("Bitte Speichern Sie diese neue Tabelle unter den Ordner -Serienbriefe.", _
vbInformation
Set fd = Application.FileDialog(msoFileDialogSaveAs)
With fd
'hier wird der Speicherort vorgegeben
.AllowMultiSelect = False 'Mehrfachauswahl
.InitialFileName = "C:\Dokumente und Einstellungen\Serienbriefe\Basis"
If .Show = -1 Then
For Each vrtSelectedItem In .SelectedItems
sport = vrtSelectedItem
Next vrtSelectedItem
Else
Exit Sub
End If
End With
Dim dName$
dName = ActiveWorkbook.Name
dName = ("Basis")
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs dName
Application.DisplayAlerts = True
Set fd = Nothing
End Sub