Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

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


Betrifft: Hilfe mit NEXT o.a. von: Rainer
Geschrieben am: 04.12.2009 13:44:21

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

  

Betrifft: AW: Hilfe mit NEXT o.a. von: fcs
Geschrieben am: 04.12.2009 15:50:34

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



  

Betrifft: AW: Hilfe mit NEXT o.a. von: Rainer
Geschrieben am: 04.12.2009 16:21:41

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