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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Kopiere_Sortiere() Dim varData, ArNew() Dim n&, nn&, nCount&, MaxRow& With Tabelle1 MaxRow = .Cells(1, 2).End(xlDown).Row varData = .Range("A1", .Cells(MaxRow, 3)) .Range(.Cells(MaxRow + 11, 1), .Cells(.Rows.Count, 3)).Clear ReDim Preserve ArNew(1 To UBound(varData, 2), 1 To UBound(varData)) For n = 1 To UBound(varData) If UCase(varData(n, 1)) = "X" Then nCount = nCount + 1 For nn = 1 To UBound(varData, 2) ArNew(nn, nCount) = varData(n, nn) Next nn End If Next n ReDim Preserve ArNew(1 To UBound(ArNew), 1 To nCount) ArNew = Application.Transpose(ArNew) With .Range("A1").Offset(MaxRow + 11).Resize(UBound(ArNew), UBound(ArNew, 2)) .Value = ArNew ''vielleicht doch sortieren? ;-) '.Sort .Cells(1, 3), xlAscending, Header:=xlNo End With End With End Sub

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

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

Beliebteste Forumthreads (12 Monate)

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

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

325 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

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

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

325 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread