Wenn in spalte "x" dann kopiere....

Matthias · 2014-03-21T23:15:58+00:00

Hallo, habe folgenden Problem: Ich habe in Spalte A manchmal ein "x" stehen und in den beiden Spalten daneben zwei Werte. Nun sollen alle Werte die ein "x" haben kopiert werden und weiter drunter (quasi sortiert) eingefügt werden. Siehe Beispiel https://www.herber.de/bbs/user/89790.xlsx Wer kann helfen? Vielen Dank und Gruß Matthias

Hallo,
müsste so funktionieren.

Sub Kopiere_Sortiere()
Dim rngData As Range, rngCol As Range
Dim nCount&, MaxRow&
With Tabelle1
MaxRow = .Cells(1, 2).End(xlDown).Row
If MaxRow > 19 Then
On Error Resume Next
Set rngData = Application.InputBox("Kann Tabellenbereich nicht erkennen!" & vbCr & _
"Bitte Bereich von Hand auswählen", Type:=8)
On Error GoTo 0
Else
Set rngData = .Range("A1", .Cells(MaxRow, 3))
End If
If rngData Is Nothing Then Exit Sub
.Range(.Cells(20, 1), .Cells(.Rows.Count, 3)).Clear
For Each rngData In rngData.Rows
If UCase(rngData.Cells(1, 1).Value) = "X" Then
nCount = nCount + 1
If Not rngCol Is Nothing Then
Set rngCol = Union(rngCol, rngData)
Else
Set rngCol = rngData
End If
End If
Next rngData
If Not rngCol Is Nothing Then
With .Cells(20, 1).Resize(nCount, 3)
rngCol.Copy
.PasteSpecial xlPasteValues 'nur Werte
.PasteSpecial xlPasteFormats 'Format
''vielleicht doch sortieren?  ;-)
'.Sort .Cells(1, 3), xlAscending, Header:=xlNo
Application.CutCopyMode = False
Application.Goto .Cells(1, 1)
End With
End If
End With
End Sub

Gruß Tino

Ich habe es jetzt so abgeändert aber leider funktioniert es nicht wie es soll

Sub Kopiere_Sortiere()
Dim rngData As Range, rngCol As Range
Dim nCount&, MaxRow&
With Tabelle1
MaxRow = .Cells(1, 25).End(xlDown).Row
If MaxRow > 19 Then
On Error Resume Next
Set rngData = Application.InputBox("Kann Tabellenbereich nicht erkennen!" & vbCr & _
"Bitte Bereich von Hand auswählen", Type:=8)
On Error GoTo 0
Else
Set rngData = .Range("Y1", .Cells(MaxRow, 3))
End If
If rngData Is Nothing Then Exit Sub
.Range(.Cells(20, 25), .Cells(.Rows.Count, 3)).Clear
For Each rngData In rngData.Rows
If UCase(rngData.Cells(1, 25).Value) = "X" Then
nCount = nCount + 1
If Not rngCol Is Nothing Then
Set rngCol = Union(rngCol, rngData)
Else
Set rngCol = rngData
End If
End If
Next rngData
If Not rngCol Is Nothing Then
With .Cells(20, 25).Resize(nCount, 3)
rngCol.Copy
.PasteSpecial xlPasteValues 'nur Werte
.PasteSpecial xlPasteFormats 'Format
''vielleicht doch sortieren?  ;-)
'.Sort .Cells(1, 3), xlAscending, Header:=xlNo
Application.CutCopyMode = False
Application.Goto .Cells(1, 25)
End With
End If
End With
End Sub

Gruß
Matthias

Wenn in spalte "x" dann kopiere....

Forumthread: Wenn in spalte "x" dann kopiere....

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Wenn in spalte "x" dann kopiere....

Forumthread: Wenn in spalte "x" dann kopiere....

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread