Hallo an Alle
Ich bin wieder an einem Punkt angekommen, wo ist nicht weiter weiß.
Mit nachfolgendem Makro werden alle Tabellenblätter als Excel Datei exportiert. So weit so gut.
Nun möchte ich aber nur das gleichlautende Tabellenblatt wie in Spalte D exportieren, wenn in Spalte B eine "2" steht. Wie lautet denn dazu die Abfrage?




Private Sub CommandButton10_Click()
'Tbl_in_einzelne_xls_Dateien_exportieren()
'Button Tabellenblätter exportieren

Dim kd_path As String
Dim prg_path As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim xNWb As Workbook
Dim FolderName As String

kd_path = Environ("userprofile") & "\nextcloud\betriebe\"
prg_path = Environ("userprofile") & "\nextcloud\Arbeitsschutz\Vorlagen GBU\GBU Excel\"


Dim wb As Workbook: Set wb = ThisWorkbook
'MsgBox wb

Dim wsDeckblatt As Worksheet: Set wsDeckblatt = wb.Worksheets("0_deckblatt")
Dim ws As Worksheet, i As Long, kd As String

kd = wsDeckblatt.Range("D4").Value
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set xWb = Application.ThisWorkbook

DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")

'FolderName = Environ("userprofile") & "\nextcloud\betriebe\" & kd & "\sicherung\" & kd & "_" & DateString
FolderName = Environ("userprofile") & "\nextcloud\betriebe\" & kd & "\sicherung\" & kd & "_" & DateString

'Prüfen ob Sicherungsverzeichnis beim Kunden vorhanden ist
Dim sicherungspfad As String
Dim sicherungspfadExistiert As String

sicherungspfad = kd_path & kd & "\Sicherung\"
sicherungspfadExistiert = Dir(sicherungspfad, vbDirectory)

If sicherungspfadExistiert = "" Then
'MsgBox "Der ausgewählte Ordner existiert nicht"
MkDir sicherungspfad
Else
MsgBox "Der ausgewählte Ordner existiert"
End If


'Tabellenblätter im Sicherungsverzeichnis sichern
If Val(Application.Version) 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
Select Case xWb.FileFormat
Case 51:
FileExtStr = ".xlsm": FileFormatNum = 51
Case 52:
If Application.ActiveWorkbook.HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsm": FileFormatNum = 51
End If
Case 56:
FileExtStr = ".xls": FileFormatNum = 56
Case Else:
FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If

MkDir FolderName

For Each xWs In xWb.Worksheets
On Error GoTo NErro

If xWs.Visible = xlSheetVisible Then
xWs.Select
xWs.Copy
xFile = FolderName & "\" & xWs.Name & FileExtStr
Set xNWb = Application.Workbooks.Item(Application.Workbooks.Count)
xNWb.SaveAs xFile, FileFormat:=FileFormatNum
xNWb.Close False, xFile
End If

NErro:
xWb.Activate

Next

MsgBox "Du findest die GBU Sicherungen im Verzeichnis " & Chr(10) & Chr(10) & FolderName
Application.ScreenUpdating = True

Application.DisplayAlerts = True

'Sheets("Link Übersicht Gef.Beurteilung").Range("a3").Select

End Sub