gefilterte Daten kopieren

Hallo,
ich bin dabei ein Makro zu schreiben, bei dem ich unter anderem gefilterte Daten kopieren muss und komme nicht weiter.
Ich habe eine Beispielmappe erstellt, damit es deutlicher wird. Ich möchte die Werte in der Spalte "Kombination" filtern, jeweils nach E, Sk und PK. Dann sollen die gefilterten Daten nach der Spalte "Summe" abwärts sortiert werden. Soweit habe ich es schon hinbekommen. Aber jetzt soll das Makro von den gefilterten Daten, also zunächst z.B. SK, die ersten fünf Zeilen nehmen und in Tabelle2 schreiben. Dann soll nach dem nächsten Kriterium gefiltert , also z.B. nach PK, und wieder nach Summe abwärts sortiert werden. Wieder sollen die ersten fünf Zeilen kopiert werden und in Tabelle2 unter die dort schon bestehende Liste SK eingefügt werden.
Hat jemand vielleicht einen Vorschlag, wie das zu bewältigen wäre? Wäre wirklich super!
https://www.herber.de/bbs/user/75454.xls
Vielen Dank und Gruß,
Kiki

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

' ********************************************************************** ' Modul: Modul1 Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Sub gefilterte_Daten() Dim wsDaten As Worksheet, wsKopie As Worksheet Dim vntCriteria() As Variant Dim lngIndex As Long, lngRow As Long, lngNext As Long On Error GoTo ErrExit Application.ScreenUpdating = False vntCriteria = Array("E", "SK", "PK") Set wsDaten = Worksheets("Tabelle1") Set wsKopie = Worksheets("Tabelle2") wsKopie.Range("A2:D" & Rows.Count).ClearContents With wsDaten .Range("A1").AutoFilter .Range("A1").CurrentRegion.Sort Key1:=.Range("C1"), Order1:=xlDescending, Header:= _ xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal For lngIndex = 0 To UBound(vntCriteria) lngNext = 1 .Range("A1").AutoFilter field:=4, Criteria1:=vntCriteria(lngIndex) For lngRow = 2 To .Range("A1").CurrentRegion.Rows.Count If .Rows(lngRow).Hidden = False Then lngNext = lngNext + 1 .Range(.Cells(lngRow, 1), .Cells(lngRow, 4)).Copy wsKopie.Cells(lngNext + lngIndex * 5, 1) If lngNext > 5 Then Exit For End If Next Next .Range("A1").AutoFilter End With ErrExit: Application.ScreenUpdating = True Set wsDaten = Nothing Set wsKopie = Nothing End Sub

Sub gefilterte_Daten() Dim wsDaten As Worksheet, wsKopie As Worksheet Dim vntCriteria() As Variant Dim lngIndex As Long, lngRow As Long, lngNext As Long On Error GoTo ErrExit Application.ScreenUpdating = False vntCriteria = Array("E", "SK", "PK") Set wsDaten = Worksheets("Tabelle1") Set wsKopie = Worksheets("Tabelle2") wsKopie.Range("A2:D" & Rows.Count).ClearContents With wsDaten .Range("A1").AutoFilter .Range("A1").CurrentRegion.Sort Key1:=.Range("C1"), Order1:=xlDescending, Header:= _ xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal For lngIndex = 0 To UBound(vntCriteria) lngNext = 1 .Range("A1").AutoFilter field:=4, Criteria1:=vntCriteria(lngIndex) For lngRow = 2 To .Range("A1").CurrentRegion.Rows.Count If .Rows(lngRow).Hidden = False Then lngNext = lngNext + 1 .Range(.Cells(lngRow, 1), .Cells(lngRow, 4)).Copy wsKopie.Cells(lngNext + lngIndex * _ 5, 1) If lngNext > 5 Then Exit For End If Next Next .Range("A1").AutoFilter End With ErrExit: Application.ScreenUpdating = True Set wsDaten = Nothing Set wsKopie = Nothing End Sub

Hallo Ulrike,
ich weiß nicht, ob ich dich richtig verstanden habe.

' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub gefilterte_Daten()
  Dim wsDaten As Worksheet, wsKopie As Worksheet
  Dim vntCriteria() As Variant, lngSortColum() As Variant
  Dim lngIndex As Long, lngCnt As Long, lngRow As Long, lngNext As Long
  'On Error GoTo ErrExit
  'Application.ScreenUpdating = False
  vntCriteria = Array("E", "SK", "PK")
  lngSortColum = Array(3, 6, 9) 'Spaltennummern der sortierung
  Set wsDaten = Worksheets("Tabelle1")
  Set wsKopie = Worksheets("Tabelle2")
  wsKopie.Range("A2:D" & Rows.Count).Clear
  wsKopie.Cells.Borders(xlEdgeBottom).LineStyle = xlNone
  With wsDaten
    For lngCnt = 0 To UBound(lngSortColum)
      .Range("A1").AutoFilter
      .Range("A1").CurrentRegion.Sort Key1:=.Cells(1, lngSortColum(lngCnt)), _
        Order1:=xlDescending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
      For lngIndex = 0 To UBound(vntCriteria)
        lngNext = 1
        .Range("A1").AutoFilter field:=4, Criteria1:=vntCriteria(lngIndex)
        For lngRow = 2 To .Range("A1").CurrentRegion.Rows.Count
          If .Rows(lngRow).Hidden = False Then
            lngNext = lngNext + 1
            .Range(.Cells(lngRow, 1), .Cells(lngRow, 9)).Copy wsKopie.Cells(lngNext + lngIndex * 5 + lngCnt * 15, 1)
            If lngNext > 5 Then Exit For
          End If
        Next
        wsKopie.Rows(lngNext + lngIndex * 5 + lngCnt * 15).Borders(xlEdgeBottom).Weight = xlMedium
      Next
    Next
    .Range("A1").AutoFilter
  End With
  ErrExit:
  Application.ScreenUpdating = True
  Set wsDaten = Nothing
  Set wsKopie = Nothing
End Sub

« Gruß Sepp »

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

303 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

gefilterte Daten kopieren

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

303 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread