Datum suchen und kopieren

Forumthread: Datum suchen und kopieren

24.12.2003 09:24:43

sigi

Hallo Profis,
ich habe alle Archive und CD`s gewälzt, konnte jedoch zu diesem Thema nichts finden.
Ich habe eine Arbeitsmappe mit 10 Blättern.
8 davon sind mit Daten versehen.
z.B. Blatt 1 Datum" Witterung" Grad
Blatt 2 Datum" Name" Nummer
usw.
Im Blatt "Übersicht" gebe ich in Zelle A1 ein Datum ein.
Nun sollen alle Daten gemäß Datum in den Blättern 1- 8 in das Blatt "Bericht" zusammmen gefasst werden.
Mit sverweis funktioniert das nicht, denn ich kann nicht wissen wieviele Eintragungen jedes Blatt pro Tag hat.
Vielleicht weis von Euch jemand eine Lösung!
Vielen Dank und frohe Weihnacht.
Gruß
Sigi

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Datum suchen und kopieren

24.12.2003 10:16:13

Ramses
AW: Datum suchen und kopieren

27.12.2003 11:02:03

sigi

AW: Datum suchen und kopieren

24.12.2003 10:16:13

Ramses

Hallo

probier mal das aus.
Das sollte funktionieren

Sub MultiSeek()
'Original Unknown
'Modified by Ramses
'Sucht in der gesamten Mappe nach einem Begriff und kopiert die
'gefundene Zeile in eine zu definfierende Ergebnistabelle
Dim wks As Worksheet
Dim rng As Range
Dim sAddress As String, sFind
Dim Cr As Long, tarWks As String
tarWks = "Tabelle2" 'Name_der_Zieltabelle
Cr = 65536
If Worksheets(tarWks).Cells(Cr, 1) = "" Then
    Cr = Worksheets(tarWks).Cells(Cr, 1).End(xlUp).Row
End If
If Cr = 0 Then Cr = 1
'Suchbegriff definieren
'sFind = InputBox("Bitte Suchbegriff eingeben:")
'Suchbegriff auf Zelle definieren
sFind = Worksheets("Übersicht").Range("A1")
For Each wks In Worksheets
    If wks.Name = tarWks Then GoTo Exitfor
    Set rng = wks.Cells.Find(what:=sFind, _
                    lookat:=xlWhole, LookIn:=xlFormulas)
    If Not rng Is Nothing Then
        sAddress = rng.Address
        Do
            Application.GoTo rng, True
            'Für die Automation kann die "If"-Anweisung auskommentiert werden
            If MsgBox("Weiter und kopieren", vbYesNo + vbQuestion) = vbNo Then Exit Sub
            wks.Rows(rng.Row).Copy Destination:=Worksheets(tarWks).Rows(Cr)
            Cr = Cr + 1
            Set rng = Cells.FindNext(after:=ActiveCell)
            If rng.Address = sAddress Then Exit Do
        Loop
    End If
Exitfor:
Next wks
MsgBox prompt:="Keine neue Fundstelle!"
End Sub

Code eingefügt mit Syntaxhighlighter 1.16

Gruss Rainer

Beliebteste Forumthreads (12 Monate)

Forumthread: Datum suchen und kopieren

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread