Makro überprüfen

Hallo an alle!
Also ich habe mir folgendes Makro aus verschiedenen Beiträgen und ein bisschen eigenarbeit zusammengefasst! Könnt ihr es euch einmal auf Fehler druchlesen oder mir eventuell verbesserungen geben? Das wäre echt sehr nett! Hänge an dem Ding schon echt lange!


Sub Etiketten_druck()
' Etiketten_druck Makro
' Makro am 23.03.2007 von Sebastian Schelb aufgezeichnet
Dim xPrinter As String
Application.ScreenUpdating = False
xPrinter = Application.ActivePrinter
On Error Resume Next
Application.ActivePrinter = "\\ User XYZ\Citizen CLP-621 auf Ne00:"
Application.ActivePrinter = "Citizen CLP-621 auf Ne00:"
Sheets("Etik_Proben").Visible = True
Sheets("Etik_Proben").Select
'Neuer Bereich
Dim i As Integer
Dim z As Integer
Set wksQuelle = ActiveSheet
Range("A1").Select  'Startposition angeben
Selection.Name = "aErsteZeile"
For z = wksQuelle.Range("aErsteZeile").Row To 6000  'letzte Zeile anpassen
If Cells(z, 1).Value  0 Then
Cells(z, 1).Name = "aLetzteZeile"
End If
Next
Range(Cells(2, 1), Cells(Range("aLetzteZeile").Row, 1)).Select 'anstelle von 20, deine letzte   _
_
Spalte
Selection.Name = "Druckbereich"
'Ende neuer Druckbereich
On Error Resume Next
Application.ActivePrinter = "\\User XYZ\Citizen CLP-621 auf Ne00:"
Application.ActivePrinter = "Citizen CLP-621 auf Ne00:"
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
ActiveWindow.SelectedSheets.Visible = False
Sheets("Etik_ArbeitsLsg.").Visible = True
Sheets("Etik_ArbeitsLsg.").Select
'Neuer Bereich 2
Set wksQuelle = ActiveSheet
Range("A1").Select  'Startposition angeben
Selection.Name = "aErsteZeile"
For z = wksQuelle.Range("aErsteZeile").Row To 6000  'letzte Zeile anpassen
If Cells(z, 1).Value  0 Then
Cells(z, 1).Name = "aLetzteZeile"
End If
Next
Range(Cells(2, 1), Cells(Range("aLetzteZeile").Row, 1)).Select 'anstelle von 20, deine letzte   _
_
Spalte
Selection.Name = "Druckbereich"
'Ende neuer Druckbereich 2
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
ActiveWindow.SelectedSheets.Visible = False
Sheets("Rohdaten").Select
Application.ActivePrinter = xPrinter
Application.ScreenUpdating = True
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Sebbi,
ich habe die Festlegung der Druckbereiche mal in eine Schleife gepackt und die Ermittlung des Druckeranschlusses mit eingefügt (siehe Deinen vorherigen Thread).

Option Explicit
Sub Etiketten_druck()
' Makro am 23.03.2007 von Sebastian Schelb aufgezeichnet
Dim xPrinter As String
Dim j As Integer, z As Integer
Dim wks As Worksheet
Dim rng As Range
Application.ScreenUpdating = False
xPrinter = Application.ActivePrinter    ' Aktiven Drucker auslesen
Call Drucker_finden
For j = 1 To Worksheets.Count
    If Worksheets(j).Name = "Etik_Proben" Or Worksheets(j).Name = "Etik_ArbeitsLsg." Then
        Set wks = Worksheets(j)
        wks.Activate
        For z = 1 To 6000  'letzte Zeile anpassen
            If wks.Cells(z, 1).Value <> 0 Then Set rng = wks.Range(Cells(2, 1), Cells(z, 1))
        Next z
        wks.PageSetup.PrintArea = rng.Address
        ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
    End If
Next
Sheets("Rohdaten").Activate
Application.ActivePrinter = xPrinter    ' Aktiven Drucker zurücksetzen
Application.ScreenUpdating = True
End Sub
Sub Drucker_finden()
'Code von Ray
Dim Ne As String, Printer$, i%
Printer = "Citizen CLP-621 auf Ne"
On Error Resume Next
For i = 1 To 99
    Ne = Format(i, "00")
    Err.Number = 0
    Application.ActivePrinter = Printer & Ne & ":"
    If Err.Number = 0 Then
        Exit For
    End If
Next
End Sub

Sub Vis () Sheets("Etik_Proben.").Visible = True Sheets("Etik_ArbeitsLsg.").Visible = True ' DRUCKEN ActiveWindow.SelectedSheets.Visible = False ActiveWindow.SelectedSheets.Visible = False 'Schug mit eiener Debugger Meldung fehl End Sub

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Makro überprüfen

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread