Spezielles Kopieren/Einfügen mit VBA

Hallo beisammen,
ich habe ein Problem, das ich mit meinen bescheidenen VBA-Kenntnissen nicht alleine lösen kann.
Ich erhalte regelmäßig vom Konzern eine tief gegliederte Produkthierarchie, die ich für meine Belange weiter bearbeiten muß - bis jetzt noch manuell, was aber ziemlich mühsam ist, weil die Datei bis zu 1.700 Zeilen hat.
Ich brauche also einen Code, der folgendes macht:
Die Spalte A ab der Zeile 8 solange durchsuchen, bis er einen Eintrag findet, diesen plus einen entsprechenden den Eintrag in der Spalte B kopiert und solange in die Zeilen darunter einfügt, bis er entweder einen neuen Eintrag findet und diesen Vorgang wiederholt oder der Eintrag auf "EOF" lautet.
Das ganze soll dann für die Spalten C, E, G und I wiederholt werden.
Zum besseren Verständnis habe ich Test-Datei beigefügt.
Es wäre super, wenn Ihr mir weiterhelfen könntet. Vielen Dank im voraus.
Gruß
Torsten
https://www.herber.de/bbs/user/35053.xls

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Torsten,
versuchs mal damit:


Sub Spalte_ausfuellen()
Dim a
a = 9
Do Until Cells(a, 1).Value = "EOF"
If Cells(a, 1).Value = "" And Cells(a - 1, 1).Value <> "" Then
Cells(a - 1, 2).Select
Selection.Copy
Cells(a, 1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
End If
If Cells(a, 1).Value = "" Then
Cells(a - 1, 1).Select
Selection.Copy
Cells(a, 1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
End If
a = a + 1
Loop
a = 9
Do Until Cells(a, 3).Value = "EOF"
If Cells(a, 3).Value = "" And Cells(a - 1, 3).Value <> "" Then
Cells(a - 1, 4).Select
Selection.Copy
Cells(a, 3).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
End If
If Cells(a, 3).Value = "" Then
Cells(a - 1, 3).Select
Selection.Copy
Cells(a, 3).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
End If
a = a + 1
Loop
a = 9
Do Until Cells(a, 5).Value = "EOF"
If Cells(a, 5).Value = "" And Cells(a - 1, 5).Value <> "" Then
Cells(a - 1, 6).Select
Selection.Copy
Cells(a, 5).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
End If
If Cells(a, 5).Value = "" Then
Cells(a - 1, 5).Select
Selection.Copy
Cells(a, 5).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
End If
a = a + 1
Loop
a = 9
Do Until Cells(a, 7).Value = "EOF"
If Cells(a, 7).Value = "" And Cells(a - 1, 7).Value <> "" Then
Cells(a - 1, 8).Select
Selection.Copy
Cells(a, 7).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
End If
If Cells(a, 7).Value = "" Then
Cells(a - 1, 7).Select
Selection.Copy
Cells(a, 7).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
End If
a = a + 1
Loop
a = 9
Do Until Cells(a, 9).Value = "EOF"
If Cells(a, 9).Value = "" And Cells(a - 1, 9).Value <> "" Then
Cells(a - 1, 10).Select
Selection.Copy
Cells(a, 9).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
End If
If Cells(a, 9).Value = "" Then
Cells(a - 1, 9).Select
Selection.Copy
Cells(a, 9).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
End If
a = a + 1
Loop
End Sub

Gruß
Holli

Sub Spalte_ausfuellen() Dim a a = 9 Do Until Cells(a, 1).Value = "EOF" If Cells(a, 1).Value = "" And Cells(a - 1, 1).Value <> "" Then Cells(a, 2).Select ActiveCell.FormulaR1C1 = "=R[-1]C[-1]&R[-1]C" Else If Cells(a, 1).Value = "" Then Cells(a, 2).Select ActiveCell.FormulaR1C1 = "=R[-1]C" End If End If a = a + 1 Loop a = 10 Do Until Cells(a, 3).Value = "EOF" If Cells(a, 3).Value = "" And Cells(a - 1, 3).Value <> "" Then Cells(a, 4).Select ActiveCell.FormulaR1C1 = "=R[-1]C[-1]&R[-1]C" Else If Cells(a, 3).Value = "" Then Cells(a, 4).Select ActiveCell.FormulaR1C1 = "=R[-1]C" End If End If a = a + 1 Loop a = 11 Do Until Cells(a, 5).Value = "EOF" If Cells(a, 5).Value = "" And Cells(a - 1, 5).Value <> "" Then Cells(a, 6).Select ActiveCell.FormulaR1C1 = "=R[-1]C[-1]&R[-1]C" Else If Cells(a, 5).Value = "" Then Cells(a, 6).Select ActiveCell.FormulaR1C1 = "=R[-1]C" End If End If a = a + 1 Loop a = 12 Do Until Cells(a, 7).Value = "EOF" If Cells(a, 7).Value = "" And Cells(a - 1, 7).Value <> "" Then Cells(a, 8).Select ActiveCell.FormulaR1C1 = "=R[-1]C[-1]&R[-1]C" Else If Cells(a, 7).Value = "" Then Cells(a, 8).Select ActiveCell.FormulaR1C1 = "=R[-1]C" End If End If a = a + 1 Loop a = 13 Do Until Cells(a, 9).Value = "EOF" If Cells(a, 9).Value = "" And Cells(a - 1, 9).Value <> "" Then Cells(a, 10).Select ActiveCell.FormulaR1C1 = "=R[-1]C[-1]&R[-1]C" Else If Cells(a, 9).Value = "" Then Cells(a, 10).Select ActiveCell.FormulaR1C1 = "=R[-1]C" End If End If a = a + 1 Loop End Sub

Sub InfosAuffuellen() Dim wks As Worksheet, Zeile As Long, Zeile1 As Long Set wks = ActiveWorkbook.Sheets("Basis") Zeile1 = 8 ' 1. Zeile mit Daten With wks 'Spalten A und B Zeile = Zeile1 Do If IsEmpty(.Cells(Zeile + 1, "A")) Then .Cells(Zeile + 1, "A") = .Cells(Zeile, "A") .Cells(Zeile + 1, "B") = .Cells(Zeile, "B") End If Zeile = Zeile + 1 Loop Until .Cells(Zeile, "A") = "EOF" 'Spalten C und D Zeile = Zeile1 Do If IsEmpty(.Cells(Zeile + 1, "C")) And .Cells(Zeile + 1, "A") = .Cells(Zeile, "A") Then .Cells(Zeile + 1, "C") = .Cells(Zeile, "C") .Cells(Zeile + 1, "D") = .Cells(Zeile, "D") End If Zeile = Zeile + 1 Loop Until .Cells(Zeile, "C") = "EOF" 'Spalten E und F Zeile = Zeile1 Do If IsEmpty(.Cells(Zeile + 1, "E")) _ And .Cells(Zeile + 1, "A") = .Cells(Zeile, "A") And .Cells(Zeile + 1, "C") = .Cells(Zeile, "C") Then .Cells(Zeile + 1, "E") = .Cells(Zeile, "E") .Cells(Zeile + 1, "F") = .Cells(Zeile, "F") End If Zeile = Zeile + 1 Loop Until .Cells(Zeile, "E") = "EOF" 'Spalten G und H Zeile = Zeile1 Do If IsEmpty(.Cells(Zeile + 1, "G")) _ And .Cells(Zeile + 1, "A") = .Cells(Zeile, "A") _ And .Cells(Zeile + 1, "C") = .Cells(Zeile, "C") _ And .Cells(Zeile + 1, "E") = .Cells(Zeile, "E") Then .Cells(Zeile + 1, "G") = .Cells(Zeile, "G") .Cells(Zeile + 1, "H") = .Cells(Zeile, "H") End If Zeile = Zeile + 1 Loop Until .Cells(Zeile, "G") = "EOF" 'Spalten I und J Zeile = Zeile1 Do If IsEmpty(.Cells(Zeile + 1, "I")) _ And .Cells(Zeile + 1, "A") = .Cells(Zeile, "A") _ And .Cells(Zeile + 1, "C") = .Cells(Zeile, "C") _ And .Cells(Zeile + 1, "E") = .Cells(Zeile, "E") _ And .Cells(Zeile + 1, "G") = .Cells(Zeile, "G") Then .Cells(Zeile + 1, "I") = .Cells(Zeile, "I") .Cells(Zeile + 1, "J") = .Cells(Zeile, "J") End If Zeile = Zeile + 1 Loop Until .Cells(Zeile, "I") = "EOF" End With End Sub

Beliebteste Forumthreads (12 Monate)

Spezielles Kopieren/Einfügen mit VBA

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

303 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Spezielles Kopieren/Einfügen mit VBA

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

303 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread