Anpassung eines Scriptes für Export

Private Sub CommandButton1_Click() ' Bereich für die Druckauswahl Dim i As Integer, j As Integer Dim arrSheets() If Application.WorksheetFunction.CountIf(Range("I3:I27"), True) = 0 Then MsgBox "Keine Auswahl getroffen" Exit Sub End If For i = 3 To 27 If Cells(i, 9) = True Then ReDim Preserve arrSheets(j) arrSheets(j) = Cells(i, 8) Sheets(arrSheets(j)).Visible = True j = j + 1 End If Next Sheets(arrSheets).Select Application.Dialogs(xlDialogPrint).Show Sheets(arrSheets).Visible = False Dim sh As Worksheet For Each sh In Worksheets sh.Visible = xlSheetVisible Next Sheets("Auswahl").Select End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub CommandButton5_Click() Sheets(Array("Januar", "Februar", "März", "April", "Mai", "Juni", "Juli", "August", " _ September", "Oktober", "November", "Dezember")).Select ActiveSheet.PageSetup.PrintArea = Range("A1:AI33").Address Selection.ExportAsFixedFormat _ Type:=xlTypePDF, _ Filename:=ThisWorkbook.Path & "\Mappe.pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, OpenAfterPublish:=True ActiveSheet.PageSetup.PrintArea = "" End Sub

Hallo Hardy,
meinst du so? (ungetestet!)

Private Sub CommandButton5_Click()
Dim objWS As Worksheet, varSheets As Variant
Dim strPath As String, strExtension As String, strName As String
Dim lngFormat As Long, lngI As Long, lngJ As Long
Dim CalculationMode As Long

On Error GoTo ErrorHandler

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  CalculationMode = .Calculation
  .Calculation = xlManual
  .DisplayAlerts = False
End With

With ThisWorkbook
  strPath = .Path & "\"
  strExtension = .Name
  strExtension = Right(strExtension, InStrRev(strExtension, "."))
  lngFormat = .FileFormat
  
  With .Sheets("Auswahl")
    If Application.WorksheetFunction.CountIf(.Range("I3:I27"), True) = 0 Then
      MsgBox "Keine Auswahl getroffen"
    Else
      strName = .Range("B3").Text
      For lngI = 3 To 27
        If .Cells(lngI, 9) = True Then
          Redim Preserve varSheets(lngJ)
          varSheets(lngJ) = .Cells(lngI, 8).Text
          .Sheets(varSheets(lngJ)).Visible = True
          lngJ = lngJ + 1
        End If
      Next
    End If
  End With
End With

If lngJ > 0 Then
  ThisWorkbook.Sheets(varSheets).Copy
  
  With ActiveWorkbook
    For Each objWS In .Worksheets
      With objWS
        .UsedRange = .UsedRange.Value
        .Range(.Cells(34, 1), .Cells(.Rows.Count, 1)).EntireRow.Delete
        .Range(.Cells(1, 36), .Cells(1, .Columns.Count)).EntireRow.Delete
      End With
    Next
    .SaveAs Filename:=strPath & strName & strExtension, FileFormat:=lngFormat
    .Close
  End With
End If

ErrorHandler:

With Err
  If .Number <> 0 Then
    MsgBox "Fehler in Prozedur:" & vbTab & "'CommandButton5_Click'" & vbLf & String(25, "") & _
      vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
      "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
      .Description & vbLf, 81968, "VBA - Fehler in Prozedur - CommandButton5_Click", .HelpFile, .HelpContext
    .Clear
  End If
End With

On Error GoTo 0

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .Calculation = CalculationMode
  .DisplayAlerts = True
  .CutCopyMode = False
  .StatusBar = False
End With

End Sub

Gruß Sepp

Private Sub CommandButton4_Click() Dim objWS As Worksheet, varSheets() As Variant Dim strPath As String, strExtension As String, strName As String Dim lngFormat As Long, lngI As Long, lngJ As Long Dim CalculationMode As Long On Error GoTo ErrorHandler With Application .ScreenUpdating = False .EnableEvents = False CalculationMode = .Calculation .Calculation = xlManual .DisplayAlerts = False End With With ThisWorkbook strPath = .Path & "\" strExtension = ".xlsx" lngFormat = 51 With Me If Application.WorksheetFunction.CountIf(.Range("I5:I16"), True) = 0 Then MsgBox "Keine Auswahl getroffen" Else strName = .Range("B3").Text For lngI = 5 To 16 If .Cells(lngI, 9) = True Then Redim Preserve varSheets(lngJ) varSheets(lngJ) = .Cells(lngI, 8).Text Sheets(varSheets(lngJ)).Visible = True lngJ = lngJ + 1 End If Next End If End With End With If lngJ > 0 Then ThisWorkbook.Sheets(varSheets).Copy With ActiveWorkbook For Each objWS In .Worksheets With objWS .UsedRange = .UsedRange.Value .Range(.Cells(34, 1), .Cells(.Rows.Count, 1)).EntireRow.Delete .Range(.Cells(1, 36), .Cells(1, .Columns.Count)).EntireRow.Delete End With Next .SaveAs Filename:=strPath & strName & strExtension, FileFormat:=lngFormat .Close End With End If ErrorHandler: With Err If .Number <> 0 Then MsgBox "Fehler in Prozedur:" & vbTab & "'CommandButton5_Click'" & vbLf & String(25, "") & _ vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _ "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _ .Description & vbLf, 81968, "VBA - Fehler in Prozedur - CommandButton5_Click", .HelpFile, .HelpContext .Clear End If End With On Error GoTo 0 With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalculationMode .DisplayAlerts = True .CutCopyMode = False .StatusBar = False End With End Sub

Beliebteste Forumthreads (12 Monate)

Anpassung eines Scriptes für Export

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Anpassung eines Scriptes für Export

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread