Anzeige
Archiv - Navigation
1256to1260
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

gefiltere Daten in einzelne Tabellen kopieren

gefiltere Daten in einzelne Tabellen kopieren
Thomas
Hallo zusammen,
ich habe das Forum mal durchsucht (denke ich zumindest ;o) ) aber nichts passendes als Lösungsansatz gefunden (oder es ist einfach Montag und ich schlafe noch halbwegs)
Ich habe eine Tabelle in der in einer Spalte Kürzel für Personen stehen (diese können sich jedoch immer wieder ändern)
Jetzt suche ich für folgendes Problem eine Lösung :
Die Zeilen in denen die Kürzel stehen sollen kopiert werden und in ein entsprechend neues Blatt (oder auch neue Datei eingefügt werden) je Kürzel kopiert werden...
BSP
Spalte F (Kürzel)
AB
CD
DE
EF
EF
nun soll die komplette Zeile in der AB steht genommen und in die Tabelle AB kopiert werden
das gleiche mit CD, DE und den beiden EF
so habe ich also dann 4 Tabellenblätter (die Bezeichnung in Abhängigkeit einer Zelle bekomme ich hin)
lass ich nun das Blatt mit anderen Werten neu berechnen kann es sein dass in der Spalte F
die Kürzel
AB
EE
RT
stehen... somit soll also AB in das bereit vorhandene Tabellenblatt AB und die anderen beiden in neue Tabellenblätter kopiert werden....
Kopieren in Abhängigkeit eines Filters usw. bekomme ich dank euch und dem Forum hin, aber das ist nicht ganz die Lösung die ich suche... ich möchte ohne Filter und dem damit verbundenen anklicken auskommen...
Vielen Dank im Voraus
Viele Grüße
Thomas

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: gefiltere Daten in einzelne Tabellen kopieren
26.03.2012 11:37:51
Tino
Hallo,
so habe ich es verstanden, kannst mal testen. (evtl. die Tabelle wo die Daten stehen anpassen)
Sub Kopiere_Daten()
Dim oDic As Object, oStartTab As Object
Dim rngFund As Range, rngSuchbereich As Range
Dim n&
Dim varK
Dim iCalc%

'Tabelle anpassen 
With ThisWorkbook.Sheets("Tabelle1")
    n = .Cells(.Rows.Count, 6).End(xlUp).Row
    If n < 2 Then Exit Sub
    Set rngSuchbereich = .Range("F2", .Cells(n, 6))
    varK = .Range("F2", .Cells(n, 7))
    Set oStartTab = ThisWorkbook.ActiveSheet
End With

With Application
    iCalc = .Calculation
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    
    Redim Preserve varK(1 To Ubound(varK), 1 To 1)
    Set oDic = CreateObject("Scripting.Dictionary")
    
    For n = 1 To Ubound(varK)
        If varK(n, 1) <> "" Then oDic(varK(n, 1)) = 0
    Next n
    varK = oDic.keys
    
    For n = Lbound(varK) To Ubound(varK)
        Set rngFund = Find_Range(varK(n), rngSuchbereich)
        If Not rngFund Is Nothing Then
           If Not Check_Tab(varK(n)) Then
                With ThisWorkbook
                    .Sheets.Add After:=.Sheets(.Sheets.Count)
                    .ActiveSheet.Name = varK(n)
                End With
           End If
           With ThisWorkbook.Sheets(varK(n))
                rngFund.EntireRow.Copy .Cells(.Rows.Count, 6).End(xlUp).Offset(1, -5)
           End With
        End If
    Next n
    
    oStartTab.Select
    .Calculation = iCalc
    .EnableEvents = True
    .ScreenUpdating = True
End With

End Sub

Function Find_Range(ByVal strSuchwert$, ByVal rngSuchbereich As Range) As Range
Dim rngTmp As Range, rngUnion As Range, strErste$

Set rngTmp = rngSuchbereich.Find(What:=strSuchwert, LookIn:=xlValues, LookAt _
        :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        True, SearchFormat:=False)
        
If rngTmp Is Nothing Then Exit Function
strErste = rngTmp.Address
Set rngUnion = rngTmp
Do
    Set rngTmp = rngSuchbereich.FindNext(rngTmp)
    Set rngUnion = Union(rngTmp, rngUnion)
Loop While strErste <> rngTmp.Address
Set Find_Range = rngUnion
End Function

Function Check_Tab(ByVal strName$) As Boolean
On Error Resume Next
Check_Tab = IsNumeric(ThisWorkbook.Sheets(strName).Index)
End Function
Gruß Tino
Anzeige
AW: gefiltere Daten in einzelne Tabellen kopieren
28.03.2012 13:56:01
Thomas
Er legt mir die erste Tabelle an und bringt dann den Laufzeitfehler 9
ab hier :
With ThisWorkbook.Sheets(varK(n))
Viele Grüße und Danke
AW: gefiltere Daten in einzelne Tabellen kopieren
28.03.2012 14:04:46
Tino
Hallo,
hier meine Beispieldatei, kann nicht sagen was bei Dir anders ist.
https://www.herber.de/bbs/user/79591.xls
Gruß Tino
AW: gefiltere Daten in einzelne Tabellen kopieren
28.03.2012 16:14:33
Thomas
Danke
ich werd es testen sobald ich hier auf Arbeit dazu komme...
Melde mich wieder ob es funktioniert hat
AW: gefiltere Daten in einzelne Tabellen kopieren
26.03.2012 12:00:41
Thomas
Hallo Tino
vielen Dank erstmals für die Mühe, ich werde es so schnell wie möglich testen und mich dann wieder melden

299 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige