Bestimmte Spalten ausschneiden mit vba

Hallo liebe Leute,
ich hab hier ein kleines vba-Problem zum ausschneiden von bestimmten spalten. Ich hatte dieses Problem schon einmal gepostet, aber das Gefühl, dass ich es nicht richtig formuliert hatte. Deshalb hier nochmals ein zweiter Versuch:
https://www.herber.de/bbs/user/111002.xlsm
Ich würde gerne die auf dem Tabellenblatt1 zu jeweils einer Personen ID gehörenden Spalten untereinander stehen haben. Ich würde gerne solange die nächste Spalte die selbe Personen-ID wie die vorherige hat, diese Spalte (von Zeile 4 bis 98) ausschneiden und unter erste Spalte (nach Zeile 98) dieser Personen ID schreiben. Die enstehende leere Spalte soll dann gelöscht werden.
Das Ergebnis soll dann wie in Tabelle2 aussehen. Wie könnte ich dies am besten mit vb formulieren?
Viele Grüße und Danke!
Antonia

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Datensortieren() Dim i As Long Dim j As Integer Dim Zeile As Long Dim Spalte As Long For i = 2 To Worksheets("Tabelle1").UsedRange.Columns.Count If Worksheets("Tabelle1").Cells(1, i) = Worksheets("Tabelle1").Cells(1, i - 1) Then Zeile = Worksheets("Tabelle2").Cells(Rows.Count, i - 1).End(xlUp).Row With Worksheets("Tabelle1") .Range(.Cells(3, i), .Cells(98, i)).Copy Destination:=Worksheets("Tabelle2").Range(. _ Cells(Zeile + 1, i - 1).Cells(Zeile + 96 + 1, i - 1)) End With End If Next i End Sub

Hallo Antonia,
ich hatte eine Makro Lösung ins Forum gestellt, aber im zweiten Thread von dir: Hier noch mal, ohne zu wissen ob es das ist was du wünschst?
mfg Piet


Option Explicit    '31.1.2017   Piet   Herber Forum
Sub Daten_kopieren()
Dim rFind As Object
Worksheets("Tabelle1").Select
'alle LastZellen abwaerts ermitteln
lz = Cells(Rows.Count, "B").End(xlUp).Row + 1
lz2 = Range("C4").End(xlDown).Row
lz3 = Range("D4").End(xlDown).Row
Set rFind = Columns(1).Find(What:="00:00 - 00:15", After:=Range("A6"), _
LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If rFind Is Nothing Then GoTo Fehler
'Spalte C kopieren
Range("C4:C" & lz2).Copy 'oder Cut nehmen
rFind.Offset(0, 1).PasteSpecial xlPasteAll
'neue LastZelle Spalte B ermitteln
Set rFind = Columns(1).FindNext(After:=Range(rFind.Address))
If rFind Is Nothing Then GoTo Fehler
'Spalte D kopieren
Range("D4:D" & lz3).Copy 'oder Cut nehmen
rFind.Offset(0, 1).PasteSpecial xlPasteAll
Application.CutCopyMode = False
Exit Sub
Fehler: MsgBox "Kann Uhrzeit '00:00 - 00:15' nicht finden"
End Sub

Beliebteste Forumthreads (12 Monate)

Bestimmte Spalten ausschneiden mit vba

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread