Daten aus excel liste in csv

Question

Hi erstmal da ich son mittelhalber excel neuling bin, habe ich mometan grad folgendes problem:

ich arbeite in einer tischlerei und dort haben wir eine neue plattensäge die man mit csv datein, die man aus excel generiert füttern kann, um sich das mühselige eintippen an der maschine zu ersparen. Soweit so gut.

Wir haben schon vorher unsere stücklisten in excel geschrieben und die liste würden wir gerne weiternutzen. Das problem ist das die exceldatei aus der ich die csv generiere eine gewisse formatierung haben muss sonst frisst die maschine die daten nicht. für die maschine muss die excel liste in zeile zwei und spalte 1 beginnen und darf keine weiteren informationen enthalten als länge/breite/dicke.
das ist aber leider total unübersichtlich und man kann damit nicht wirklich arbeiten.

mein gedanklicher ansatz ist das ich unsere "schöne" liste nehme und ganz normal mit den daten fülle und dann quasi zellen auswählen kann die er mir in eine csv übergibt oder ich sie in eine neue liste generieren kann, die ich dann in die csv umwandle

hoffe das das problem verständlich ist und noch viel mehr hoffe ich das es dafür eine einfache und simple lösung gibt :-D

Answer 1

Hallo,

ich habe dir mal ein Makro für die Erstellung einer Datei für den CSV-Export der Daten aus dem aktuellen Arbeitsblatt geschrieben. Der Code gehört in ein Standard-Modul deiner "schönen" Datei.

Kopiert werden die benötigten Daten in dem Arbeitsblatt aus den Zeilen, bei denen in der Spalte "Bauteil" etwas steht. Da du verbundene Zellen hast, wird immer nur die erste Zeile der vebundenen Zellen geprüft. Ist die Zelle mit Bauteil leer, so wird der Kopiervorgang gestoppt.

Sub csv_erstellen()

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) = "Bezeichnung_Zuschnitt"
ThisWorkbook.Worksheets(blattz).Cells(1, 2) = "Rohmass_Laenge"
ThisWorkbook.Worksheets(blattz).Cells(1, 3) = "Rohmass_Breite"
ThisWorkbook.Worksheets(blattz).Cells(1, 4) = "Anzahl_Zuschnitt"
ThisWorkbook.Worksheets(blattz).Cells(1, 5) = "Materialnummer"

'Zeile in Zieldatei definieren, Daten werden ab Zeile 2 geschrieben
zzeile = 2

'Kopieren der Daten
For zeile = 9 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 Daten kopiert
Worksheets(blattz).Cells(zzeile, 1) = Worksheets(blattq).Cells(zeile, 3).Value 'Bezeichnung
Worksheets(blattz).Cells(zzeile, 2) = Worksheets(blattq).Cells(zeile, 8).Value 'Rohmass_Laenge
Worksheets(blattz).Cells(zzeile, 3) = Worksheets(blattq).Cells(zeile, 11).Value 'Rohmass_Breite
Worksheets(blattz).Cells(zzeile, 4) = Worksheets(blattq).Cells(zeile, 7).Value 'Anzahl_Zuschnitt
Worksheets(blattz).Cells(zzeile, 5) = Worksheets(blattq).Cells(zeile, 5).Value 'Materialnummer
'Zeilennummer für Zielblatt um 1 erhöhen
zzeile = zzeile + 1

Next zeile

'Tabelle mit Daten für csv-Export in neue Arbeitsmappe verschieben
ThisWorkbook.Sheets(blattz).Move

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Gruß

M.O.

Answer 2

vielen, vielen, vielen, vielen, vielen, vielen, vielen, vielen, vielen, vielen, vielen, vielen lieben dank für die hilfe, es funltioniert exakt genauso wie ich es mir erträumt habe. :-D Danke!!!!!!!!!!!!!!

eine frage hab ich doch noch.....

ist es möglich das er bei der generierung der neuen datei, den datei namen der ursprünglichen liste + die bezeichnung von dem blatt wo die daten drinstehen als neuen dateinamen für die csv nimmt?

PS: DANKE

Answer 3

Hallo,

hier noch mit Speicherung als CSV-Datei (Trennzeichen Semikolon) und Namensvorschlag:

Sub csv_erstellen()

Dim i, zeile, zzeile As Integer
Dim Dateiname_neu, mappeq, blattq, blattz, dn As String
Dim bExists As Boolean
Dim Rueckgabe

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'Name für neues Arbeitsblatt definieren
blattz = "csv_fuer_maschine"

'Name der aktuellen Arbeitsmappe und des aktiven Arbeitsblattes
mappeq = ActiveWorkbook.Name
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) = "Bezeichnung_Zuschnitt"
ThisWorkbook.Worksheets(blattz).Cells(1, 2) = "Rohmass_Laenge"
ThisWorkbook.Worksheets(blattz).Cells(1, 3) = "Rohmass_Breite"
ThisWorkbook.Worksheets(blattz).Cells(1, 4) = "Anzahl_Zuschnitt"
ThisWorkbook.Worksheets(blattz).Cells(1, 5) = "Materialnummer"

'Zeile in Zieldatei definieren, Daten werden ab Zeile 2 geschrieben
zzeile = 2

'Kopieren der Daten
For zeile = 9 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 Daten kopiert
Worksheets(blattz).Cells(zzeile, 1) = Worksheets(blattq).Cells(zeile, 3).Value 'Bezeichnung
Worksheets(blattz).Cells(zzeile, 2) = Worksheets(blattq).Cells(zeile, 8).Value 'Rohmass_Laenge
Worksheets(blattz).Cells(zzeile, 3) = Worksheets(blattq).Cells(zeile, 11).Value 'Rohmass_Breite
Worksheets(blattz).Cells(zzeile, 4) = Worksheets(blattq).Cells(zeile, 7).Value 'Anzahl_Zuschnitt
Worksheets(blattz).Cells(zzeile, 5) = Worksheets(blattq).Cells(zeile, 5).Value 'Materialnummer
'Zeilennummer für Zielblatt um 1 erhöhen
zzeile = zzeile + 1

Next zeile

'Tabelle mit Daten für csv-Export in neue Arbeitsmappe verschieben
ThisWorkbook.Sheets(blattz).Move

'Hier wird die erstelle CSV-Datei gespeichert, Tennzeichen ist das Semikolon
'Soll als Trennzeichen das Komma benutzt werden ist local:=False zu setzen
'Pfad anpassen!
Dateiname_neu = Application.GetSaveAsFilename("C:\Test\" & mappeq & "_" & blattq & ".csv", FileFilter:="Excel Files (*.csv), *.csv")
If Dateiname_neu <> "False" Then
ActiveSheet.SaveAs Filename:=Dateiname_neu, FileFormat:=xlCSV, Local:=True
End If

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Du musst nur den Pfad "C:\Test\" auf deine Bedürfnisse anpassen.

Gruß

M.O.

Answer 4

Holzliste jetzt hab ich wieder ein wie ich denke eher kleines problem... habe das makro von dir nur versucht auf die andere art von tabelle anzupassen, aber wenn er jetzt die daten exportieren soll dann überspringt er einige zeilen....... obwohl er die daten die in die erste zeile geschrieben richtig exportiert aber dann in der liste anfängt sachen zu überspringen.

ist sicher nur was ganz ganz kleines aber ich find es nicht......

Answer 5

und ich habe versucht das blatt bzw einige zellen zu sperren, aber wenn ich das mache dann kann ich das makro nicht mehr durchlaufen lassen weil das blatt gesperrt ist. gibts da nicht irgendeine möglichkeit?????

Answer 6

Hallo,

in Antwort 11 habe ich geschrieben:

Kopiert werden die benötigten Daten in dem Arbeitsblatt aus den Zeilen, bei denen in der Spalte "Bauteil" etwas steht. Da du verbundene Zellen hast, wird immer nur die erste Zeile der vebundenen Zellen geprüft. Ist die Zelle mit Bauteil leer, so wird der Kopiervorgang gestoppt.

In deiner "schönen Liste" hast du jeweils in zwei Zeilen Zellen verbunden und dort etwas hineingeschrieben. In deiner Problemliste steht in jeder Zelle etwas. Da das Makro jedoch nur jede 2. Zeile prüft und kopiert, werden eben einige Zeilen übersprungen.
Du solltest in deiner "schönen Liste" mal die verbundenen Zeilen ändern. Die sind nicht notwendig, das kannst du genau so gut über die Zeilenhöhe hinbekommen. Dann kann man das Makro entsprechend anpassen.

Damit jede Zeile geprüft und ggf. kopiert musst du

For zeile = 9 To Worksheets(blattq).UsedRange.SpecialCells(xlCellTypeLastCell).Row Step 2

in

For zeile = 9 To Worksheets(blattq).UsedRange.SpecialCells(xlCellTypeLastCell).Row

ändern.

Gruß

M.O.

Answer 7

Hallo Benjamin,

hier noch etwas zum Blattschutz.
Hast du das Arbeitsblatt geschützt zu musst die folgenden beiden Zeilen am Anfang bzw. Ende des Makros einfügen
Hier das Beispiel mit eine Passwort:

'Blattschutz aufheben:
Sheets(ActiveSheet).Unprotect "Hier das Passwort"

'Blatt schützen:
Sheets(ActiveSheet).Protect "Hier das Passwort"

Ohne Passwort sieht es dann so aus:

'Blattschutz aufheben:
Sheets(ActiveSheet).Unprotect

'Blatt schützen:
Sheets(ActiveSheet).Protect

Das Makro für die Tabelle werde ich entsprechend deiner Pager-Mitteilung anpassen.

Gruß

M.O.

Answer 8

wenn ich dein oberes beispiel einfüge sagt er mir das : laufzeitfehler 13 typen unverträglich

Sub Holzliste()

'Blattschutz aufheben:
Sheets(ActiveSheet).Unprotect "holz"

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
mappeq = ActiveWorkbook.Name
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) = "Laenge"
ThisWorkbook.Worksheets(blattz).Cells(1, 3) = "Breite"
ThisWorkbook.Worksheets(blattz).Cells(1, 4) = "Anzahl"
ThisWorkbook.Worksheets(blattz).Cells(1, 5) = "Materialnummer"
ThisWorkbook.Worksheets(blattz).Cells(1, 6) = "Funierrichtung"

'Zeile in Zieldatei definieren, Daten werden ab Zeile 2 geschrieben
zzeile = 2

'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 Daten kopiert
Worksheets(blattz).Cells(zzeile, 1) = Worksheets(blattq).Cells(zeile, 3).Value 'Bauteil
Worksheets(blattz).Cells(zzeile, 2) = Worksheets(blattq).Cells(zeile, 9).Value 'Laenge
Worksheets(blattz).Cells(zzeile, 3) = Worksheets(blattq).Cells(zeile, 12).Value 'Breite
Worksheets(blattz).Cells(zzeile, 4) = Worksheets(blattq).Cells(zeile, 8).Value 'Anzahl
Worksheets(blattz).Cells(zzeile, 5) = Worksheets(blattq).Cells(zeile, 5).Value 'Materialnummer
Worksheets(blattz).Cells(zzeile, 6) = Worksheets(blattq).Cells(zeile, 16).Value 'Funierrichtung
'Zeilennummer für Zielblatt um 1 erhöhen
zzeile = zzeile + 1

Next zeile

'Tabelle mit Daten für csv-Export in neue Arbeitsmappe verschieben
ThisWorkbook.Sheets(blattz).Move

'Hier wird die erstelle CSV-Datei gespeichert, Tennzeichen ist das Semikolon
'Soll als Trennzeichen das Komma benutzt werden ist local:=False zu setzen
'Pfad anpassen!
Dateiname_neu = Application.GetSaveAsFilename("C:\Test\" & mappeq & "_" & blattq & ".csv", FileFilter:="Excel Files (*.csv), *.csv")
If Dateiname_neu <> "False" Then
ActiveSheet.SaveAs Filename:=Dateiname_neu, FileFormat:=xlCSV, Local:=True
End If

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

'Blatt schützen:
Sheets(ActiveSheet).Protect "holz"

End Sub

steht doch aber an den richtigen stellen oder????

Answer 9

Hallo Benjamin,

das mit dem Blattschutz sollte so funktionieren:

Sub Holzliste()

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) = "Laenge"
ThisWorkbook.Worksheets(blattz).Cells(1, 3) = "Breite"
ThisWorkbook.Worksheets(blattz).Cells(1, 4) = "Anzahl"
ThisWorkbook.Worksheets(blattz).Cells(1, 5) = "Materialnummer"
ThisWorkbook.Worksheets(blattz).Cells(1, 6) = "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 Daten kopiert
Worksheets(blattz).Cells(zzeile, 1) = Worksheets(blattq).Cells(zeile, 3).Value 'Bauteil
Worksheets(blattz).Cells(zzeile, 2) = Worksheets(blattq).Cells(zeile, 9).Value 'Laenge
Worksheets(blattz).Cells(zzeile, 3) = Worksheets(blattq).Cells(zeile, 12).Value 'Breite
Worksheets(blattz).Cells(zzeile, 4) = Worksheets(blattq).Cells(zeile, 8).Value 'Anzahl
Worksheets(blattz).Cells(zzeile, 5) = Worksheets(blattq).Cells(zeile, 5).Value 'Materialnummer
Worksheets(blattz).Cells(zzeile, 6) = Worksheets(blattq).Cells(zeile, 16).Value 'Funierrichtung
'Zeilennummer für Zielblatt um 1 erhöhen
zzeile = zzeile + 1

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

Gruß

M.O.

Answer 10

Hallo Benjamin,

und hier das modifizierte Makro für die Holzliste:

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

Schau mal, ob das so funktioniert, wie du willst.

Gruß

M.O.