Sub Holzliste_2()
Dim i, zeile, zzeile As Integer
Dim blattq, blattz As String
Dim bExists As Boolean
Dim Rueckgabe
'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False
'Name für neues Arbeitsblatt definieren
blattz = "csv_fuer_maschine"
'Name des aktuellen Arbeitsblattes
blattq = ActiveSheet.Name
' Testen ob ein Arbeitsblatt mit dem Namen "csv_fuer_maschine" existiert
For i = 1 To Sheets.Count
If Sheets(i).Name = blattz Then
bExists = True: Exit For
End If
Next i
If bExists Then
' ... wenn ja: Nachfragen, ob Inhalt des Blattes gelöscht werden soll
Rueckgabe = MsgBox("Ein Blatt mit dem Namen " & blattz & " existiert bereits! Sollen die Daten in dem Blatt überschrieben werden?", 4, "Frage")
Select Case Rueckgabe
Case vbYes
'Inhalte des Blatts werden gelöscht
ThisWorkbook.Worksheets(blattz).Activate
Range(Cells(1, 1), Cells(Worksheets(blattz).UsedRange.SpecialCells(xlCellTypeLastCell).Row, Worksheets(blattz).UsedRange.SpecialCells(xlCellTypeLastCell).Column)).ClearContents
Case vbNo
'Makro wird beendet
MsgBox "Abbruch durch Benutzer", vbOKOnly, "Abbruch-Meldung"
Exit Sub
End Select
Else
' ... wenn nein: ein solches Blatt erstellen.
'Neues Blatt wird am Ende eingefügt
Worksheets.Add After:=Worksheets(Worksheets.Count)
'Neues Blatt benennen
ActiveSheet.Name = blattz
End If
'Überschrift in Export-Blatt einfügen
ThisWorkbook.Worksheets(blattz).Cells(1, 1) = "Bauteil"
ThisWorkbook.Worksheets(blattz).Cells(1, 2) = "Material"
ThisWorkbook.Worksheets(blattz).Cells(1, 3) = "Laenge"
ThisWorkbook.Worksheets(blattz).Cells(1, 4) = "Breite"
ThisWorkbook.Worksheets(blattz).Cells(1, 5) = "Anzahl"
ThisWorkbook.Worksheets(blattz).Cells(1, 6) = "Materialnummer"
ThisWorkbook.Worksheets(blattz).Cells(1, 7) = "Funierrichtung"
'Zeile in Zieldatei definieren, Daten werden ab Zeile 2 geschrieben
zzeile = 2
'Prüfen, ob Blattschutz vorhanden ist und falls ja, dann Blattschutz aufheben:
If Worksheets(blattq).ProtectContents = True Then
Worksheets(blattq).Unprotect "holz"
End If
'Kopieren der Daten
For zeile = 7 To Worksheets(blattq).UsedRange.SpecialCells(xlCellTypeLastCell).Row Step 2
'Prüfen ob in Bezeichnung etwas steht, falls nicht wird die Schleife verlassen (das Kopieren beendet)
If IsEmpty(Worksheets(blattq).Cells(zeile, 3)) = True Then Exit For
'ab hier werden die ersten Daten kopiert
Worksheets(blattz).Cells(zzeile, 1) = Worksheets(blattq).Cells(zeile, 3).Value 'Bauteil
Worksheets(blattz).Cells(zzeile, 3) = Worksheets(blattq).Cells(zeile, 9).Value + 5 'Länge
Worksheets(blattz).Cells(zzeile, 4) = Worksheets(blattq).Cells(zeile, 12).Value + 5 'Breite
Worksheets(blattz).Cells(zzeile, 6) = Worksheets(blattq).Cells(zeile, 5).Value 'Materialnummer
Worksheets(blattz).Cells(zzeile, 7) = Worksheets(blattq).Cells(zeile, 16).Value 'Funierrichtung
'Prüfen, ob Unterseite leer ist
If IsEmpty(Worksheets(blattq).Cells(zeile, 7)) = True Then
Worksheets(blattz).Cells(zzeile, 2) = Worksheets(blattq).Cells(zeile, 6).Value 'Material
Worksheets(blattz).Cells(zzeile, 5) = Worksheets(blattq).Cells(zeile, 8).Value * 2 'Anzahl
'Zeilennummer für Zielblatt um 1 erhöhen
zzeile = zzeile + 1
Else
'hier werden die Daten kopiert, wenn in Unterseite auch etwas steht
Worksheets(blattz).Cells(zzeile, 5) = Worksheets(blattq).Cells(zeile, 8).Value 'Anzahl
'Zeilennummer für Zielblatt um 1 erhöhen
zzeile = zzeile + 1
'Daten für Unterseite kopieren
Worksheets(blattz).Cells(zzeile, 1) = Worksheets(blattq).Cells(zeile, 3).Value 'Bauteil
Worksheets(blattz).Cells(zzeile, 2) = Worksheets(blattq).Cells(zeile, 7).Value 'Material
Worksheets(blattz).Cells(zzeile, 3) = Worksheets(blattq).Cells(zeile, 9).Value + 5 'Laenge
Worksheets(blattz).Cells(zzeile, 4) = Worksheets(blattq).Cells(zeile, 12).Value + 5 'Breite
Worksheets(blattz).Cells(zzeile, 5) = Worksheets(blattq).Cells(zeile, 8).Value 'Anzahl
Worksheets(blattz).Cells(zzeile, 6) = Worksheets(blattq).Cells(zeile, 5).Value 'Materialnummer
Worksheets(blattz).Cells(zzeile, 7) = Worksheets(blattq).Cells(zeile, 16).Value 'Funierrichtung
'Zeilennummer für Zielblatt um 1 erhöhen
zzeile = zzeile + 1
End If
Next zeile
'Blattschutz wieder herstellen, falls keiner vorhanden ist
If Worksheets(blattq).ProtectContents = False Then
Worksheets(blattq).Protect "holz"
End If
'Tabelle mit Daten für csv-Export in neue Arbeitsmappe verschieben
ThisWorkbook.Sheets(blattz).Move
'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True
End Sub
M.O.