Office: Werte kopieren und einfügen in neue Zeile

Mimir · 16. April 2016

Hallo liebes Forum,

nachdem mir gerade schon geholfen wurde, hier nun eine weitere Frage:

Ich möchte, dass das Makro nach Zellen sucht, in denen der Inhalt mit einem Buchstaben beginnt. Wird eine solche Zelle gefunden, dann soll der Inhalt dieser Zelle kopiert werden und direkt unter die Zeile, aus der der Inhalt kopiert wurde, in eine neue Zeile eingefügt werden.

Da ich mich sogar mit der Erklärung etwas schwer tue, habe ich zwei Dateien angefügt. "Vorher.xlsx" gibt die originalen Daten an und "Nacher" den gewünschten Zustand (Änderungen in Rot).

Zur Erklärung:
In Zeile 2 wird nach einer Zelle beginnend mit einem Buchstaben gesucht. E2 ist eine solche Zelle. Der Inhalt wird nun kopiert. Es wird eine neue Zeile hinzugefügt, direkt unter Zeile 2. In diese neue Zeile wird nun im Feld B3 der Wert aus E2 eingefügt. Weiter soll dann der Wert F2 in B4 (neu geschaffen) kopiert werden. J2 in B5.
Danach soll mit Zeile 6 (vormals 3) weitergemacht werden, usw.

Ich hoffe, ich konnte das Problem einigermaßen verständlich beschreiben.

Vielen Dank für die schon erhaltene und noch kommende Hilfe.

Mit besten Grüßen,

:)

Hasso · 18. April 2016

Hallo Mimir,

hier meine Lösung: Code:

Option Explicit

Sub umschichten()

Dim lngZeile As Long
Dim intSpalte As Integer
Dim intZaehler As Integer
Dim intLetzteSpalte As Integer

With Worksheets("Tabelle1")
'letzte Spalte ermitteln:
intLetzteSpalte = .Cells(1, .Columns.Count).End(xlToLeft).Column
lngZeile = 2
'Wiederholen, solange in Spalte A etwas steht:
Do While .Cells(lngZeile, 1) ""
For intSpalte = 2 To intLetzteSpalte
.Cells(lngZeile, intSpalte).Select
'Wenn in der Zelle keine Zahl steht:
If Not IsNumeric(.Cells(lngZeile, intSpalte)) Then
intZaehler = intZaehler + 1
'Neue Zeile einfügen:
Rows(lngZeile + intZaehler).Insert Shift:=xlDown
'Zahl aus Spalte A übernehmen:
.Cells(lngZeile + intZaehler, 1) = .Cells(lngZeile, 1)
'Inhalt der Zelle mit dem Buchstaben eintragen:
.Cells(lngZeile + intZaehler, 2) = .Cells(lngZeile, intSpalte)
End If
If .Cells(lngZeile, 1) = "" Then Exit For
Next intSpalte
lngZeile = lngZeile + intZaehler + 1
intZaehler = 0
Loop
End With

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Du startest den Code mit einem Doppelklick auf Zelle A1. Den Auslöser könnte man aber auch auf einen Button legen.

xlph · 18. April 2016

Code:

Public Sub xlph()

Dim avntData() As Variant
Dim iavntData1 As Long
Dim iavntData2 As Long

Dim avntResult() As Variant
Dim iavntResult As Long

Dim lngStringCount As Long

With Tabelle1

With .Range("A1").CurrentRegion
With Intersect(.Cells, .Offset(1))
avntData() = .Value
lngStringCount = Abs(WorksheetFunction.CountA(.Cells) - WorksheetFunction.Count(.Cells))
End With
End With

If lngStringCount = 0 Then Exit Sub

ReDim avntResult(1 To lngStringCount, 1 To 2)

For iavntData1 = LBound(avntData, 1) To UBound(avntData, 1)
For iavntData2 = LBound(avntData, 2) + 1 To UBound(avntData, 2)
If Not IsNumeric(avntData(iavntData1, iavntData2)) Then
iavntResult = iavntResult + 1
avntResult(iavntResult, 1) = avntData(iavntData1, 1)
avntResult(iavntResult, 2) = avntData(iavntData1, iavntData2)
End If
Next
Next

With .Range("A1").CurrentRegion
.Cells(.Rows.Count, 1).Offset(1).Resize(UBound(avntResult, 1), UBound(avntResult, 2)).Value = avntResult()
End With

With .Range("A1").CurrentRegion
.Sort .Cells(1), xlAscending, Header:=xlYes
End With

End With

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Mimir · 18. April 2016

Hallo Hasso,

das ist perfekt. Ich danke Dir vielmals. Die Lösung läuft super und spart mir unendlich viel Zeit. Ich bin super erleichtert :-D

Nochmals tausendfachen Dank für diese schnelle und ausgezeichnete Antwort.

Beste Grüße,

Mimir

Mimir · 18. April 2016

Hallo xlph,

auch Deine Lösung ist perfekt. Das zweite Mal, dass Du mir heute geholfen hast. Super geil wie schnell das ging und wie wunderschön jetzt mein Sheet aussieht.

Ich danke euch beiden herzlichst für die Hilfe!

Beste Grüße,

Mimir

Office: Werte kopieren und einfügen in neue Zeile

Werte kopieren und einfügen in neue Zeile

Werte kopieren und einfügen in neue Zeile

Werte kopieren und einfügen in neue Zeile

Werte kopieren und einfügen in neue Zeile - Similar Threads - Werte kopieren einfügen

Excel VBA - Code Hilfe (Spalten, Werte kopieren etc.)

Werte aus mehreren Spalten kopieren und darunter einfügen

Wert in Zelle kopieren und in nächster freie Zelle einfügen

Alle Werte ungleich Null kopieren und in neues Blatt einfügen

Wert suchen, bestimmten Bereich kopieren und einfügen

Werte kopieren und untereinander einfügen

VBA Zeile Kopien nur Werte einfügen