Zellen anhand Inhalt auswählen und kopieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Intersect(ActiveSheet.Userange, ActiveSheet.Usedrange.Offset(1,0).SpecialCells( _ xlCelltypeVisible).Copy Workbooks("DeineDatei.xls").Sheets("DeinSheet").Cells(Rows.count,1).end(xlup).Offset(1,0).PasteSpecial xlPasteAll

Hallo Matthias,

' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub kopiereDaten()
  Dim rngCopy As Range
  Dim lngRow As Long, lngLast As Long, lngIndex As Long
  Dim varParam(1) As Variant

  On Error GoTo ErrExit
  GMS

  varParam(0) = Array(400, 800, 2, "Tabelle2") 'min-Wert, max-Wert, Bedingung, Zieltabelle
  varParam(1) = Array(800, 1200, 1, "Tabelle3")

  With Sheets("Tabelle1") 'Quelltabelle
    lngLast = .Cells(Rows.Count, 1).End(xlUp).Row
    For lngIndex = 0 To UBound(varParam)
      .Range(.Cells(1, 39), .Cells(lngLast, 39)).FormulaR1C1 = "=IF(AND(RC[-36]>=" & varParam(lngIndex)(0) & ",RC[-36]<" & varParam(lngIndex)(1) & ",RC[-34]=" & varParam(lngIndex)(2) & "),NA(),"""")"
      On Error Resume Next
      Set rngCopy = .Columns(39).SpecialCells(xlCellTypeFormulas, xlErrors)
      On Error GoTo ErrExit
      If Not rngCopy Is Nothing Then
        lngRow = Sheets(varParam(lngIndex)(3)).Cells(Rows.Count, 1).End(xlUp).Row + 1
        rngCopy.EntireRow.Copy Sheets(varParam(lngIndex)(3)).Cells(lngRow, 1)
        Sheets(varParam(lngIndex)(3)).Columns(39) = ""
      End If
      Set rngCopy = Nothing
      .Columns(39) = ""
    Next
  End With



  ErrExit:
  With Err
    If .Number <> 0 Then MsgBox "Fehler " & .Number & vbLf & vbLf & _
      .Description & vbLf & vbLf & "In Prozedur (kopiereDaten) in Modul Modul2", _
      vbExclamation, "Fehler in Modul2 / kopiereDaten"
  End With

  GMS True

End Sub

Public Sub GMS(Optional ByVal Modus As Boolean = False)

  Static lngCalc As Long

  With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    If Not Modus Then lngCalc = .Calculation
    If Modus And lngCalc = 0 Then lngCalc = -4105
    .Calculation = IIf(Modus, lngCalc, -4135)
    .Cursor = IIf(Modus, -4143, 2)

  End With

End Sub

Gruß Sepp

Hallo Mathias,
zu deinem 1. Problem:
Wenn du in einem Durchlauf mehrere gefilterte Datenblöcke in das gleiche Blatt kopieren willst, dann muss die Zielzeile in jedem Block neu berechnet werden. Siehe nachfolgendes Beispiel mit markierten ("'### 2009-11-10" anzupassenden/einzufügenden Zeilen.
Zu Problem Nr. 2:
Um die Daten, die in ein Blatt kopiert werden sollen, in einem Blöck zu übertragen, mussen die von den einzelnen Filtern selektierten Zeilen in einer Hilfsspalte markiert werden. Nach dem Setzen der Markierung wird dann der Filter auf die Markierungen gesetzt. Man kann dann auch die Blattnamen direkt verwenden, statt des etwas anonymen Arrays.
Hier die Textdatei des Codes, den du am besten in ein eigenes Modul der Datei einfügst oder als Ersatz für den Code im Modul "modFilter".
https://www.herber.de/bbs/user/65706.txt
Beim Setzen des Autofilters ist es nicht unbedingt erforderlich nach jedem Filter ".ShowAllData" zu setzen. Es ist ausreichend den Wert eines bereits gesetzten Filters zu ändern, wenn die anderen Filterwerte gleich bleiben. Das beschleunigt die Makroarbeit nochmals ein wenig.
Gruß
Franz

Sub DatenEinsortierenFilter()
'Daten werden in den Quelldateien per Autofilter selektiert und kopiert
'dabei werden keine Formeln kopiert
Dim wbZiel As Workbook, wbQuelle As Workbook
Dim wksQuelle As Worksheet, wksZiel() As Worksheet
Dim ZeileZ() As Long, ZeileQ As Long, arrDateien As Variant
Dim intI As Long, intBlatt As Long
Dim StatusCalc As Long, bolAbbruch As Boolean
'Makrobremsen lösen
With Application
.EnableEvents = False
StatusCalc = .Application.Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Zielobjekte setzen
Set wbZiel = ActiveWorkbook
ReDim wksZiel(1 To 2)
ReDim ZeileZ(1 To 2)
Set wksZiel(1) = wbZiel.Worksheets("400_800")
Set wksZiel(2) = wbZiel.Worksheets("801_1200")
'Quelldatei(en) auswählen
arrDateien = Application.GetOpenFilename(Filefilter:="Excel (*.xl*),*.xl*", _
Title:="Bitte Datendateien auswählen - Mehrfachauswahl ist möglich", _
MultiSelect:=True)
If Not IsArray(arrDateien) Then GoTo Beenden
'gewählte Datei(en) abarbeiten
For intI = LBound(arrDateien) To UBound(arrDateien)
'Letzte Datenzeile in den Ziel-Blättern ermitteln
For intBlatt = LBound(wksZiel) To UBound(wksZiel)
'        ZeileZ(intBlatt) = LastRow(wksZiel(intBlatt))          '###  2009-11-10
If wksZiel(intBlatt).Rows.Count - ZeileZ(intBlatt) =400", Operator:=xlAnd, Criteria2:=" 1 Then
intBlatt = 1
ZeileZ(intBlatt) = LastRow(wksZiel(intBlatt))           '###  2009-11-10
.Range(.Cells(2, 1), .Cells(ZeileQ, 38)).Copy _
Destination:=wksZiel(intBlatt).Cells(ZeileZ(intBlatt) + 1, 1)
End If
.ShowAllData
'Prüfbedingungen 2 für Kopieren der Daten
With .Range(.Cells(1, 1), .Cells(ZeileQ, 38))
'Filter Spalte E
.AutoFilter Field:=5, Criteria1:=2
'Filter SPalte C
.AutoFilter Field:=3, Criteria1:=">800", Operator:=xlAnd, Criteria2:=" 1 Then
intBlatt = 2
ZeileZ(intBlatt) = LastRow(wksZiel(intBlatt))           '###  2009-11-10
.Range(.Cells(2, 1), .Cells(ZeileQ, 38)).Copy _
Destination:=wksZiel(intBlatt).Cells(ZeileZ(intBlatt) + 1, 1)
End If
.ShowAllData
End With
'Quell-Datei ohne speichern wieder schliessen
wbQuelle.Close savechanges:=False
Next intI
Beenden:
'Makrobremsen zurücksetzen
With Application
.EnableEvents = True
.Calculation = StatusCalc
.ScreenUpdating = True
End With
MsgBox "Fertig"
End Sub

Beliebteste Forumthreads (12 Monate)

Zellen anhand Inhalt auswählen und kopieren

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

307 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zellen anhand Inhalt auswählen und kopieren

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

307 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread