Var. Bereich in neues Blatt kopieren

Hallo zusammen,
da VBA absolut neu für mich ist und ich keine adäquate Lösung finden konnte, hoffe ich hier auf Hilfe zu stoßen.
Ich habe ein vereinfachtes Muster meiner Datei hochgeladen. Ich habe bereits ein Makro erstellt, welches das Blatt Anhang erstellt.
Zu meinem Problem:
Ich möchte das der gefüllte Bereich von A6 bis H47 des Blattes "Erstellung" in das neue Blatt "Anhang" kopiert wird. Dabei sollen die Spalten C bis H jedoch nur kopiert werden, wenn eine Produkt-Nr. in Zeile 6 der entsprechenden Spalte eingetragen ist.
Die Spalten die eine Produkt-Nr. enthalten (in der hochgeladenen Datei C-F) sollen bis zu der Zeile kopiert werden, in der etwas steht. Maximal bis Spalte 47. Im Beispiel also Spalte C bis Zeile 22, Spalte D bis Zeile 22, Spalte E bis 32 und Spalte F bis Zeile 27.
Spalte G und H enthalten im Beispiel keine Produkt-Nr. und sollen nicht in das neue Blatt kopiert werden.
Spalte A und B sollen bis zu der Zeile kopiert werden, welches die "tiefste" bei den Spalten C bis H ist. Also im Beispiel Zeile 32. Hier auch maximal bis zur Zeile 47.
Im Blatt "Anhang" kann die neue Tabelle direkt in Zelle A1 starten und eingefügt werden (Die Zelle A6 im Blatt "Erstellung" wird also zur Zelle A1 im Blatt "Anhang".
Meine Beispieldatei:
https://www.herber.de/bbs/user/136787.xlsm
Wenn ihr mir einen Code zur Verfügung stellen könnt, wäre ich euch sehr dankbar!
MfG
ExcelRocker

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo ExcelRocker,
hier mein Lösungsvorschlag.
LG
Franz

Sub Anhang()
' Daten aus "Erstellung" in neues Blatt übertragen
Dim ws As Worksheet, wsErst As Worksheet
Dim zei As Long, zei_1 As Long, Zei_L
Dim spa As Long, spa_L As Long, spa_A As Long
Dim bolBlock As Boolean
'Blatt mit Daten einer Variablen zuweisen
Set wsErst = Worksheets("Erstellung")
' neues Blatt "Anhang" in Excel erstellen
Set ws = ThisWorkbook.Worksheets.Add
ws.Name = "Anhang"
'gefüllten Bereich in neues Blatt kopieren
Application.ScreenUpdating = False
With wsErst
zei_1 = 6 'Zeile mit den Spaltentiteln setzen
'letzte ausgefüllte Spalte in Zeile 6 ermitteln
spa_L = .Cells(zei_1, .Columns.Count).End(xlToLeft).Column
'Startwert für letzte Zeile setzen
Zei_L = zei_1
'letzte Zeile mit Wert Spalte C bis zur letzten Spalte ermitteln
bolBlock = True
For spa = 3 To spa_L
If .Cells(zei_1, spa).Text = "" Then
bolBlock = False
Else
zei = .Cells(.Rows.Count, spa).End(xlUp).Row
If zei > Zei_L Then Zei_L = zei
End If
Next
'1. Einfügespalte in "Anhang" setzen
spa_A = 1
'Spalten A +B kopieren
.Range(.Cells(zei_1, 1), .Cells(Zei_L, 2)).Copy ws.Cells(1, spa_A)
spa_A = 2
'Spalten mit Produkt-Nrn kopieren
If bolBlock = True Then
'Spalten als Block kopieren - es gibt keine Lücke bei den Produkt-Nrn
spa_A = spa_A + 1
.Range(.Cells(zei_1, 3), .Cells(Zei_L, spa_L)).Copy ws.Cells(1, spa_A)
Else
'spaltenweise kopieren - es gibt Lücken bei den Produkt-Nrn
For spa = 3 To spa_L
If .Cells(zei_1, spa).Text  "" Then
spa_A = spa_A + 1
.Range(.Cells(zei_1, spa), .Cells(Zei_L, spa)).Copy ws.Cells(1, spa_A)
End If
Next
End If
End With
' mit dem ausgefüllten Blatt "Anhang" was machen
With ws
.Columns.AutoFit
Exit Sub ' Notausgang während Testphase
' Ecxel Blatt "Anhang" wieder löschen
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End With
End Sub

Beliebteste Forumthreads (12 Monate)

Var. Bereich in neues Blatt kopieren

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Var. Bereich in neues Blatt kopieren

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread