HERBERS Excel-Forum - das Archiv

Thema: Hilfe mit NEXT o.a. | Herbers Excel-Forum

Hilfe mit NEXT o.a.
Rainer

Hallo,
habe nun mit Eurer Hilfe folgenden Code zusammengestellt:
Sub copyAktSpplan()
'prüfen ob Angaben vollständig gemacht wurden
If Worksheets("intern").Range("H46").Value < 7 Then frmCheck.Show: Exit Sub
Dim objWb As Workbook, rng As Range, rngC As Range, rngDel As Range
Dim aPlan As String
aPlan = Worksheets("Erfassung").Range("V37").Value
ThisWorkbook.Sheets(aPlan).Visible = xlSheetVisible
'für Auszug Variable reservieren
Dim sPfad As String
Dim sDatei As String
sPfad = Worksheets("eMail").Range("G39")
'sDatei = "Turnierplan - TT.MM.JJJJ (J) Gruppe #"
sDatei = "Turnierplan - " & Worksheets("Erfassung").Range("U20") & _
" (" & Worksheets("Erfassung").Range("U15") & _
") " & Worksheets(aPlan).Range("G1")
Application.ScreenUpdating = False
Sheets(aPlan).Copy
Set objWb = ActiveWorkbook
With objWb
With .Sheets(1)
.UsedRange = .UsedRange.Value
Set rng = .Range(.PageSetup.PrintArea)
For Each rngC In .UsedRange.Columns
If Intersect(rngC, rng) Is Nothing Then
If rngDel Is Nothing Then
Set rngDel = rngC.EntireColumn
Else
Set rngDel = Union(rngDel, rngC.EntireColumn)
End If
End If
Next
If Not rngDel Is Nothing Then rngDel.Delete
Set rngDel = Nothing
For Each rngC In .UsedRange.Rows
If Intersect(rngC, rng) Is Nothing Then
If rngDel Is Nothing Then
Set rngDel = rngC.EntireRow
Else
Set rngDel = Union(rngDel, rngC.EntireRow)
End If
End If
Next
If Not rngDel Is Nothing Then rngDel.Delete
Set rngDel = Nothing
End With
'löscht alle Button's
Dim objOle As OLEObject
For Each objOle In ActiveSheet.OLEObjects
objOle.Visible = False
Next
MsgBox "Die Datei " & sDatei & ".xls ]" & vbLf & _
"wird nun im Verzeichnis" & vbLf & _
sPfad & vbLf & _
"gespeichert."
'neue Tabelle speichern
Application.DisplayAlerts = False 'Speichert ohne Meldung von MS (speichern ohne Makros)
.SaveAs sPfad & "\" & sDatei & ".xls"
.Close
Application.DisplayAlerts = True
End With
Application.ScreenUpdating = True
Set objWb = Nothing
Set rng = Nothing
Set rngDel = Nothing
Set rngC = Nothing
End Sub
Nun müsste ich den Code noch etwas ergänzen, damit ich je nach Plan zwei Dateien gespeichert bekomme.
Folglich müssten vor Sheets(aPlan).Copy die Zeilen
    If Sheets("intern").Range("J12") = "nein" Then ' Zweiseitiger Druck?
Sheets(aPlan).Copy
Sheets("intern").Range("M12") = True ' Auswahl alle Mannschaften
Else
Sheets("intern").Range("N12") = True ' Auswahl Gruppe 1
Sheets(aPlan).Copy
Sheets("intern").Range("O12") = True ' Auswahl Gruppe 2
Sheets(aPlan).Copy
End If
Damit ich nicht Sheets(aPlan).Copy dreimal reinkopieren muss hätte ich es mit einem neuen Sub mit obiger If-Anweisung gemacht und jeweils statt "Sheets(aPlan).Copy" "copyAktSpplan" aufgerufen.
Frage: Liese sich das auch innerhalb des Codes realisieren, ohne ...Copy unnötig zu kopieren?
Gruß Rainer

AW: Hilfe mit NEXT o.a.
fcs

Hallo Rainer,
die neuen Prozeduren müßten dann etwa so aussehen.
Option Explicit
Private wbThis As Workbook, wksErfassung As Worksheet, wksEmail As Worksheet, _
wksIntern As Worksheet
Sub BlattCopy()
'Zuweisungen zu den in Haupt- und Unterprozedur verwendeten Objektvariablen
Set wbThis = ActiveWorkbook
Set wksIntern = wbThis.Worksheets("intern")
Set wksEmail = wbThis.Worksheets("eMail")
Set wksErfassung = wbThis.Worksheets("Erfassung")
'prüfen ob Angaben vollständig gemacht wurden
If wksIntern.Range("H46").Value < 7 Then
frmCheck.Show: Exit Sub
End If
If wksIntern.Range("J12") = "nein" Then ' Zweiseitiger Druck?
Call copyAktSpplan
wksIntern.Range("M12") = True ' Auswahl alle Mannschaften
Else
wksIntern.Range("N12") = True ' Auswahl Gruppe 1
Call copyAktSpplan
wksIntern.Range("O12") = True ' Auswahl Gruppe 2
Call copyAktSpplan
End If
Set wksIntern = Nothing: Set wksEmail = Nothing: Set wksErfassung = Nothing
Set wbThis = Nothing
End Sub
Sub copyAktSpplan()
Dim objWb As Workbook, rng As Range, rngC As Range, rngDel As Range
Dim wks_aPlan As Worksheet
Set wks_aPlan = wbThis.Sheets(wksErfassung.Range("V37").Value)
wks_aPlan.Visible = xlSheetVisible
'für Auszug Variable reservieren
Dim sPfad As String
Dim sDatei As String
sPfad = wksEmail.Range("G39")
'sDatei = "Turnierplan - TT.MM.JJJJ (J) Gruppe #"
sDatei = "Turnierplan - " & wksErfassung.Range("U20") & _
" (" & wksErfassung.Range("U15") & _
") " & wks_aPlan.Range("G1")
Application.ScreenUpdating = False
wks_aPlan.Copy
Set objWb = ActiveWorkbook
With objWb
With .Sheets(1)
.UsedRange = .UsedRange.Value
Set rng = .Range(.PageSetup.PrintArea)
For Each rngC In .UsedRange.Columns
If Intersect(rngC, rng) Is Nothing Then
If rngDel Is Nothing Then
Set rngDel = rngC.EntireColumn
Else
Set rngDel = Union(rngDel, rngC.EntireColumn)
End If
End If
Next
If Not rngDel Is Nothing Then rngDel.Delete
Set rngDel = Nothing
For Each rngC In .UsedRange.Rows
If Intersect(rngC, rng) Is Nothing Then
If rngDel Is Nothing Then
Set rngDel = rngC.EntireRow
Else
Set rngDel = Union(rngDel, rngC.EntireRow)
End If
End If
Next
If Not rngDel Is Nothing Then rngDel.Delete
Set rngDel = Nothing
End With
'löscht alle Button's
Dim objOle As OLEObject
For Each objOle In ActiveSheet.OLEObjects
objOle.Visible = False                    'so werden Buttons nur ausgeblendet
'      objOle.Delete                             'so werden Buttons nur ausgeblendet
Next
MsgBox "Die Datei " & sDatei & ".xls ]" & vbLf & _
"wird nun im Verzeichnis" & vbLf & _
sPfad & vbLf & _
"gespeichert."
'neue Tabelle speichern
Application.DisplayAlerts = False 'Speichert ohne Meldung von MS (speichern ohne Makros)
.SaveAs sPfad & "\" & sDatei & ".xls"
.Close
Application.DisplayAlerts = True
End With
Application.ScreenUpdating = True
Set objWb = Nothing
Set rng = Nothing
Set rngDel = Nothing
Set rngC = Nothing
End Sub

AW: Hilfe mit NEXT o.a.
Rainer

Hallo fcs,
im Nachhinein hatte ich auch noch festgestellt, dass ich wohl ein eigenes Sub machen muss, da ich sonst ja die Variablen der neuen Dateinamen nicht gehabt hätte.
Dachte, dass ich mit NEXT den Copy-Befehl einfach wiederholen hätte können.
Aber vielen Dank für Deine Hilfe.
Das mit den
'Zuweisungen zu den in Haupt- und Unterprozedur verwendeten Objektvariablen
hatte ich nicht gewusst bzw. gekannt.
Gruß Rainer