AW: Name vergeben
26.07.2009 13:56:05
RolfK
Hallo Herbert,
hier der gesamt Code:
Sub NeueTlnDrucken()
Dim AnzZeilenZiel As Integer, AnzSpaltenZiel As Integer, Teilnehmer As Integer
Dim Eingabe As String
Dim wsQuelle As Worksheet, wsZiel As Worksheet, wsDruck As Worksheet
Set wsQuelle = ThisWorkbook.Worksheets("Teilnehmer")
Set wsZiel = ThisWorkbook.Worksheets("NeuZugang")
Set wsDruck = ThisWorkbook.Worksheets("DruckZugang")
'altdaten löschen
AnzZeilenZiel = wsZiel.Range("A1").CurrentRegion.Rows.Count
AnzSpaltenZiel = wsZiel.Range("A1").CurrentRegion.Columns.Count
'wsZiel.Range(Cells(2, 1), Cells(AnzZeilenZiel, AnzSpaltenZiel)).Select
If AnzZeilenZiel > 1 Then
With wsZiel
.Range(.Cells(2, 1), .Cells(AnzZeilenZiel, AnzSpaltenZiel)).ClearContents
End With
End If
'Namen Löschen
On Error Resume Next
ThisWorkbook.Names("DatenNeuZugang").Delete
On Error GoTo 0
'neue daten filtern
With wsQuelle
.Range("QuelleTlnDaten").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=wsZiel.Range("KritDatNeue"), CopyToRange:= _
wsZiel.Range("ZielNeueTln"), Unique:=False
End With
'LfdNummern vergeben
AnzZeilenZiel = wsZiel.Range("A1").CurrentRegion.Rows.Count
AnzSpaltenZiel = wsZiel.Range("A1").CurrentRegion.Columns.Count
'wsZiel.Cells(2, 1).Select
'wsZiel.Range(Cells(2, 1), Cells(AnzZeilenZiel, 1)).Select
If AnzZeilenZiel > 1 Then
With wsZiel
.Cells(2, 1) = 1
.Range(.Cells(2, 1), .Cells(AnzZeilenZiel, 1)).DataSeries Rowcol:=xlColumns, Type:= _
xlLinear, Date:=xlDay, _
Step:=1, Trend:=False
End With
End If
'Namen vergeben
ThisWorkbook.Names.Add Name:="DatenNeuZugang", RefersToR1C1:= _
"=NeuZugang!R2C1:R" & AnzZeilenZiel & "C" & AnzSpaltenZiel
'prüfen der Tlnauswahl
wsZiel.Activate
Eingabe = MsgBox("Für die in der Liste aufgeführten Teilnehmer werden die Anmeldezettel _
gedruckt. Bitte wählen...", vbOKCancel, "Bitte prüfen!")
If Eingabe = vbCancel Then Exit Sub
'drucken
For Teilnehmer = 2 To AnzZeilenZiel
With wsDruck
.Range("LfdTlnNeu") = Teilnehmer - 1
.PrintOut Copies:=2, Collate:=True
'.PrintPreview
End With
Next Teilnehmer
wsDruck.Activate
End Sub
Wie gesagt, das besonders komische daran ist, dass es in meinen Augen nicht nachvollzeihbar mal funktioniert und mal nicht.
Gruß Rolf