Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Tabellenblätter gem. Checkbox Auswahl exportieren

Forumthread: Tabellenblätter gem. Checkbox Auswahl exportieren

Tabellenblätter gem. Checkbox Auswahl exportieren
22.09.2017 17:45:25
Joel
Ich habe eine Datei mit mehreren Tabellenblätter. 4 davon liefern mir Resultate welche ich je nach Bedarf durch die Auswahl der 4 Checkboxen in eine separate Datei exportieren kann. Das ist mir mit folgendem Code gelungen:
= Dim bReportDelta As Boolean: bReportDelta = Worksheets(constWorksheetNameSteuerung) .Shapes(constCheckBoxReportDelta).OLEFormat.Object.Value > = 0
Dim bReportRating As Boolean: bReportRating = Worksheets(constWorksheetNameSteuerung).Shapes(constCheckBoxReportRating).OLEFormat.Object.Value >= 0
Dim bReportInventar As Boolean: bReportInventar = Worksheets(constWorksheetNameSteuerung).Shapes(constCheckBoxReportInventar).OLEFormat.Object.Value >= 0
Dim bReportEvolan As Boolean: bReportEvolan = Worksheets(constWorksheetNameSteuerung).Shapes(constCheckBoxReportEvolan).OLEFormat.Object.Value >= 0
Dim i As Integer, Sh As Integer
If bReportDelta Then
If bReportRating Then
If bReportInventar Then
If bReportEvolan Then
Sheets(Array("Bilanz_ER", "Auswertung_Rating", "Auswertung_Inventar", "Auswertung_Evolan")).Copy
Else
Sheets(Array("Bilanz_ER", "Auswertung_Rating", "Auswertung_Inventar")).Copy
End If
ElseIf bReportEvolan Then
Sheets(Array("Bilanz_ER", "Auswertung_Rating", "Auswertung_Evolan")).Copy
Else
Sheets(Array("Bilanz_ER", "Auswertung_Rating")).Copy
End If
ElseIf bReportInventar Then
If bReportEvolan Then
Sheets(Array("Bilanz_ER", "Auswertung_Inventar", "Auswertung_Evolan")).Copy
Else
Sheets(Array("Bilanz_ER", "Auswertung_Inventar")).Copy
End If
ElseIf bReportEvolan Then
Sheets(Array("Bilanz_ER", "Auswertung_Evolan")).Copy
Else
Sheets(Array("Bilanz_ER")).Copy
End If
ElseIf bReportRating Then
If bReportInventar Then
If bReportEvolan Then
Sheets(Array("Auswertung_Rating", "Auswertung_Inventar", "Auswertung_Evolan")).Copy
Else
Sheets(Array("Auswertung_Rating", "Auswertung_Inventar")).Copy
End If
ElseIf bReportEvolan Then
Sheets(Array("Auswertung_Rating", "Auswertung_Evolan")).Copy
Else
Sheets(Array("Auswertung_Rating")).Copy
End If
ElseIf bReportInventar Then
If bReportEvolan Then
Sheets(Array("Auswertung_Inventar", "Auswertung_Evolan")).Copy
Else
Sheets(Array("Auswertung_Inventar")).Copy
End If
ElseIf bReportEvolan Then
Sheets(Array("Auswertung_Evolan")).Copy
End If
Nun suche ich nach einer Vereinfachung, damit allenfalls auch eine 5 Auswahlmöglichkeit eingefügt werden kann ohne x-Zeilen neuen Code zu schreiben. Gibt es Variante mit einer Schlaufe?
Anzeige

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Tabellenblätter gem. Checkbox Auswahl exportieren
22.09.2017 20:32:50
Sepp
Hallo Joel,
für eine Schleife, solltest du die Checkboxen mt einem Index versehen, aufbauend auf deinem Beispiel kannst du es so lösen.
Ungetestet!
Sub halloween()
Dim varSheets() As Variant, lngIndex As Long


With Worksheets(constWorksheetNameSteuerung)
  If .Shapes(constCheckBoxReportDelta).OLEFormat.Object.Value >= 0 Then Redim _
    varSheets(lngIndex): varSheets(lngIndex) = "Bilanz_ER": lngIndex = lngIndex + 1
  If .Shapes(constCheckBoxReportRating).OLEFormat.Object.Value >= 0 Then Redim Preserve _
    varSheets(lngIndex): varSheets(lngIndex) = "Auswertung_Rating": lngIndex = lngIndex + 1
  If .Shapes(constCheckBoxReportInventar).OLEFormat.Object.Value >= 0 Then Redim Preserve _
    varSheets(lngIndex): varSheets(lngIndex) = "Auswertung_Inventar": lngIndex = lngIndex + _
    1
  If .Shapes(constCheckBoxReportEvolan).OLEFormat.Object.Value >= 0 Then Redim Preserve _
    varSheets(lngIndex): varSheets(lngIndex) = "Auswertung_Evolan": lngIndex = lngIndex + 1
End With

If lngIndex > 0 Then Sheets(varSheets).Copy

End Sub

Gruß Sepp

Anzeige
AW: Tabellenblätter gem. Checkbox exportieren
25.09.2017 14:34:07
Joel
Hallo Sepp
Vielen Dank für die Vereinfachung, das hilft mir sehr viel weiter nachdem ich schon mehrere Stunden vergebens herumgebastelt habe. Es funktioniert einwandfrei!
Danke und Gruss
;

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Entdecke mehr
Finde genau, was du suchst

Die erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden

Suche nach den besten Antworten
Unsere beliebtesten Threads

Entdecke unsere meistgeklickten Beiträge in der Google Suche

Top 100 Threads jetzt ansehen
Anzeige