Speicherort aus Zelle holen
25.12.2007 09:55:14
Wolfgang
zunächst auch von mir allen Forumsmitgliedern, insbesondere den aktiven "Beantwortern", frohe Weihnachtsfeiertage !
Kaum habe ich mit Hilfe des Forums eine Frage klären können, taucht die nächste Frage auf. Wie kann ich den untenstehenden Code ändern, damit der Speicherpfad der im ausgeblendeten Tabellenblatt "Basis", Zelle "A30" enthalten ist, genommen wird und dann das generierte Tabellenblatt "Seriendruck" ohne Nachfrage automatisch gespeichert bzw. überschrieben wird. Danke schon jetzt wieder für die Rückmeldungen.
Herzliche Grüße
Wolfgang
Sub Serienbrief()
' Variablendeklaration
Dim intCounter As Integer
Dim shSource As Worksheet
Dim lngRow As Long
Dim wb As Workbook
Dim fd As FileDialog
Dim vrtSelectedItem As Variant
Dim strUser As String
strUser = Environ("Username")
strUser = Trim$(Replace(strUser, ".GST", ""))
'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 frmNavigator
Set fd = Application.FileDialog(msoFileDialogSaveAs)
With fd
'hier wird der Speicherort vorgegeben
.AllowMultiSelect = False 'Mehrfachauswahl
.InitialFileName = "C:\Dokumente und Einstellungen\" & strUser & "\Desktop\Test\Seriendruck"
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 = ("Seriendruck")
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs dName
Application.DisplayAlerts = True
Set fd = Nothing
End Sub
