Zellwerte suchen per Makro im Modul und auf anderes Blatt kopieren

Hallo liebe Leute!

Ich bin neu hier im Forum und brauche bitte eure Hilfe. Ich soll für meinen Chef ein Makro schreiben welches in einer Spalte nach einem Wert sucht (z.B: Monat "Oktober") und dann die danebenstehenden Werte kopiert und in ein anderes Blat dersselben Mappe wieder an einer bestimmten Zelle einfügt.

Meine bisherigen Ideen waren immer nur mit Fehlermeldungen gekrönt...

Wenn mir jemand von Euch die Lust und Liebe hätte mir zu helfen?

Danke

Mein Code bisher:

Monat$ = InputBox("Für Welches Monat soll der Bericht erstellt werden ?" + Chr$(13), "Suchfeld für Bericht ")

y% = 1 'Zeile
x% = 1 'Spalte
Z% = 0 'Fehlervariable

Dim Grlbl$(31)

SUCHSCHLEIFE:
y% = y% + 1
a1$ = a$
a$ = Worksheets("Grlbl").Cells(y%, x%)

If a1$ = "" And a$ = "" Then Z% = Z% + 1 Else Z% = 0
If Z% > 50 Then 'Kein entsprechend zur Eingabe passendes Monat gefunden
Antwort = MsgBox("Es gibt kein Monat" + Chr$(13) + Chr$(13) + Monat$ + " !", 0, "") ' Meldung anzeigen.
Exit Sub

End If
If a$ = Monat$ Then GoTo DATENUEBERGABE Else GoTo SUCHSCHLEIFE




DATENUEBERGABE:

'Übergabe Beschreibung von Spalte "A"
'Nach y% (Zeile) eines weiterzählen +1 und Wert auslesen uns kopieren nach "Arbeitsnachweis" beginnend bei Spalte "L7" und eines weiterzählen.

'zeile = y%
'Spalte = x%

ActiveCell(y%, x%).Select
ActiveCell.Copy Destination:=Worksheets("Arbeitsnachweis").Cells(10, 10)
'Sheets("Arbeitsnachweis").Range("D7").Paste 'Wert einfügen

[ravenheart]

Warum einfach, wenn es auch kompliziert geht?

Angenommen, die Daten, aus denen die Werte entnommen werden sollen, stehen auf dem Blatt "Tabelle1" im Bereich von A2 bis D18.
Die Suchbegriffe, zu denen die Daten gefunden werden sollen, stehen in Spalte A dahinter gibt es 3 Spalten mit den zu suchenden Daten.

Auf Blatt 2 (Tabelle2) machst Du dann zuerst ein Eingabe - Feld, ich nehme mal Zelle E1
Da kommt der Suchbegriff ("Oktober") rein....
Da drunter sollen in den Zellen E2, F2 und G2 die Ergebnisse aus Spalten B, C und D von Tabelle1 gezeigt werden.

Die Formel für E2 lautet dann:

=WENN(ISTFEHLER(SVERWEIS($E$1;Tabelle1!$A$2:$D$18;2;FALSCH));"nicht gefunden";SVERWEIS($E$1;Tabelle1!$A$2:$D$18;2;FALSCH))

Übersetzt:
Wenn [die Suche] einen Fehler ergibt, schreibe "nicht gefunden",
sonst gib mir neben der Fundstelle den Inhalt der 2. Spalte.

(Die Spalte, in der gesucht wird, ist immer "Spalte 1"; nach rechts ab der wird durchnummeriert, 2, 3, 4...)

Für F2 wäre die Formel dann:

=WENN(ISTFEHLER(SVERWEIS($E$1;Tabelle1!$A$2:$D$18;3;FALSCH));"nicht gefunden";SVERWEIS($E$1;Tabelle1!$A$2:$D$18;3;FALSCH))

Für G2 wäre es:

=WENN(ISTFEHLER(SVERWEIS($E$1;Tabelle1!$A$2:$D$18;4;FALSCH));"nicht gefunden";SVERWEIS($E$1;Tabelle1!$A$2:$D$18;4;FALSCH))

u.s.w...

Rabe

[ravenheart]

Hier die Muster-Tabelle im Anhang zum Gucken...

Rabe

[Veelkerd]

.....Diese Lösung [
=WENN(ISTFEHLER(SVERWEIS($E$1;Tabelle1!$A$2:$D$18;3;FALSCH));"nicht gefunden";SVERWEIS($E$1;Tabelle1!$A$2:$D$18;3;FALSCH))]
klappt adaptiert wunderbar auch für andere Forumsmitglieder.

Bliebe die Frage, wie man das für eine bestimmten Bereich mehrfach wiederholen kann.

Damit ich niemandem die Zeit stehle, weil ichs nicht anständig beschreibe, was mir Kopfzerbrechen macht.

Im angehängten Beispiel links ein Tabellenbereich 1, in dem mehrfach der Suchbegriff DADA vorkommt. Rechts Tabelle 2 mit den Zellinhalten, die in den drei Spalten rechts von DADA in dem Tabellenbereich 1 stehen.

Den ersten "DADA" findet die Anweisung ohne Schwierigkeiten, aber wie ließe sich der gesamte Tabellenbereich 1 durchsuchen, schließlich die weiteren gefundenen Werte in Tabelle 2 untereinanderkopieren.
(Ich kenne den Bereich, weiß aber nicht wie groß der Sprung zum nächsten DADA)

Vielen Dank für jede Hilfe (man verzeihe mir falls es Geübten völlig einfach erscheint).

Gruß
Ve

[ravenheart]

Nun, die Funktion kann immer nur einen Wert finden. Dass Such-Werte mehrfach vorkommen können, hattest Du nicht gesagt! Da müsste man ganz anders vorgehen!

Rabe

Ok! Kleiner Lösungstipp vielleicht ? Würde mit sehr, sehr helfen.

Vielen Dank

Ve

[Tanto]

Hallo Community

Ein Beispiel

Liebe Grüße Tanto

Option Explicit
Sub SuchenKopieren()
    Dim Suche As Range
    Dim Zhler As Long
    Dim Eingabe As String
    Dim Schalter As Boolean
    Zhler = 1
    Eingabe = Application.InputBox("Eingabe des Monats")
    Do
        Set Suche = Workbooks(1).Worksheets(1).Range("A" & Zhler & ":A" & Workbooks(1).Worksheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Find(Eingabe)
        If Not Suche Is Nothing Then
            Worksheets(1).Rows(Suche.Row & ":" & Suche.Row).Copy Worksheets(2).Cells(Worksheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1, 1)
            Zhler = Suche.Row + 1
            Schalter = True
        Else
            If Schalter = False Then
                MsgBox ("Keine Daten vorhanden !")
            Else
                MsgBox ("Daten wurden Kopiert !")
            End If
            Exit Do
        End If
    Loop
End Sub

Korrigiert

[Sascha Oliver Haak]

@Simone

Versuche fogenden Code einmal

Dim c As Range
Dim OK As Variant
Dim iZähler As Integer

Const Tab1 = "Tabelle1"                                                                     ' Tabelle in der gesucht wird
Const Tab2 = "Tabelle2"                                                                     ' Tabelle in der kopiert wird

Sub suchen()
    iZähler = 5                                                                             ' Zähler für die Tabelle in die kopiert wird
    With Worksheets(Tab1).Range("a1:a500")                                                  ' Hier wird in Tabelle 1 in den Zellen a1 bis a500 gesucht
    OK = InputBox("Wonach soll gesucht werden? " + Chr$(13) + Chr$(13), "Suchen")           ' OK beinhaltet den Wert der gesucht werden soll
    Set c = .Find(Trim(OK), LookIn:=xlValues)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do                                                                                  ' Schleife beginn -->>
              Range("A" + Trim(Str$(c.Row)) + ":G" + Trim(Str$(c.Row))).Select              ' Spalten A bis G werden selektiert
              Selection.Copy                                                                ' hier kopiert
              Sheets(Tab2).Select                                                     ' Tabelle2 selektieren
              Range("A" + Trim(Str$(iZähler))).Select                                       ' In Tabelle2 in Zeile iZähler selektieren
              Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
              :=False, Transpose:=False                                                     ' Werte kopieren
              iZähler = iZähler + 1                                                         ' Zähler erhöhen
              Sheets(Tab1).Select                                                              ' Tabelle1 wieder selektieren
            Set c = .FindNext(c)                                                            ' nächsten Treffer suchen
        Loop While Not c Is Nothing And c.Address <> firstAddress                           ' Schleife Ende   <<--
    End If
End With

End Sub
' Eine kleine Hilfe von mir bitte damit einwenig rumspielen um
' zu verstehen was gemacht wird.
'
' In VBA im Bereich diese Arbeitsmappe kopieren
' Auf Excel-ebene unter EXTRAS, MAKRO, MAKROS
' DieseArbeitsmappe -> Makro suchen anklicken und Optionen auswählen
' Buchstabe einsetzen für Tastenkombi z.B. a
' nun steht das Makro mit der gewählten Tastenkombi zur Verfügung

' With Worksheets(Tab1).Range("a1:a500")                               <--   Worksheets(Tab1).Range("Dein_Bereich") anpassen
' Range("A" + Trim(Str$(c.Row)) + ":G" + Trim(Str$(c.Row))).Select  <--   A bis G ändern für die eigene Tabelle


' Sascha Oliver Haak für PPF 2009

@Tanto
habe Deinen Code probiert und dieser lässt bei mir Excel hängen.
Oder die Suche dauert ziemlich lange?

Gruß
Sascha

[Tanto]

Hallo Community

@Sacha
Danke hab es korrigiert

Eine weitere Variante, wobei der Autofilter genutzt wird

Liebe Grüße Tanto

 
Sub FilterKopieren()
    Worksheets("Tabelle1").Range("A1").AutoFilter Field:=1, Criteria1:=InputBox("Eingabe")
    Worksheets("Tabelle1").Rows("2:" & Worksheets("Tabelle1").UsedRange.SpecialCells(xlCellTypeLastCell).Row).Copy Worksheets("Tabelle2").Range("A" & Worksheets("Tabelle2").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
    Worksheets("Tabelle1").Range("A1").AutoFilter
End Sub

[Sascha Oliver Haak]

@Tanto

Die Suche per Autofilter produziert Fehler, wenn

- die Liste nicht direkt hinter der Suchzeile beginnt. Heißt beginnt die Liste bei "A5" produziert der Autofilter bei "A1" einen Fehler.

- die Liste durch Leerzellen unterbrochen wird (A5 - Oktober, A6 - September, A7 - leer, A8 leer, A9 - Januar)

Aber ansonsten ist das eine schöne Variante.

Gruß
Sascha

[Tanto]

Hallo Sacha und all

Noch eine Variante,ein Array

Liebe grüße Tanto

Option Explicit
Sub ArraySucheKopie()
    Worksheets(1).Activate
    Dim Spalte As Long
    Dim Index As Long
    Dim Tb1Zeilen As Long
    Dim Tb1Spalte As Long
    Dim Eingabe As String
    Dim Zelle As Long
    Tb1Zeilen = Worksheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row
    Tb1Spalte = Worksheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Column
    ReDim ArrayA(1 To Tb1Zeilen, 1 To Tb1Spalte) As Variant
    ReDim ArrayNeu(1 To Tb1Zeilen, 1 To Tb1Spalte) As Variant
    Eingabe = InputBox("Eingabe")
    ArrayA = Range(Cells(1, 1), Cells(Tb1Zeilen, Tb1Spalte))
    For Zelle = 1 To Tb1Zeilen
        If ArrayA(Zelle, 1) = Eingabe Then
            Index = Index + 1
            For Spalte = 1 To Tb1Spalte
                ArrayNeu(Index, Spalte) = ArrayA(Zelle, Spalte)
            Next Spalte
        End If
    Next Zelle
    If Index = 0 Then
        MsgBox ("Keine Daten vorhanden !")
    Else
        Worksheets(2).Activate
        Range(Cells(2, 1), Cells(Tb1Zeilen, Tb1Spalte)).Resize(UBound(ArrayNeu())) = ArrayNeu
        MsgBox ("Daten wurden Kopiert !")
    End If
End Sub

[Mistertolle]

Hi Leute!!
Das was Ihr hier gemacht habt, ist genau das, was ich suche.
Nur eine Frage wie geht das ganze ohne dieser tollen Eingabebox?
Ich brauche nur den Wert in der Zelle z.B A1, dann Enter und los gehts.
(Ich komme aus den Tal der Ahnungslosen)

Dim c As Range
Dim OK As Variant
Dim iZähler As Integer

Const Tab1 = "Standardliste" ' Tabelle in der gesucht wird
Const Tab2 = "Tabelle1" ' Tabelle in der kopiert wird

Sub qwe()
iZähler = 5 ' Zähler für die Tabelle in die kopiert wird
With Worksheets(Tab1).Range("b1:b500") ' Hier wird in Tabelle 1 in den Zellen a1 bis a500 gesucht
OK = InputBox("Wonach soll gesucht werden? " + Chr$(13) + Chr$(13), "Suchen") ' OK beinhaltet den Wert der gesucht werden soll
Set c = .Find(Trim(OK), LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do ' Schleife beginn -->>
Range("b" + Trim(Str$(c.Row))).Select ' Spalten A bis G werden selektiert
Selection.Copy ' hier kopiert
Sheets(Tab2).Select ' Tabelle2 selektieren
Range("a" + Trim(Str$(iZähler))).Select ' In Tabelle2 in Zeile iZähler selektieren
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False ' Werte kopieren
iZähler = iZähler + 1 ' Zähler erhöhen
Sheets(Tab1).Select ' Tabelle1 wieder selektieren
Set c = .FindNext(c) ' nächsten Treffer suchen
Loop While Not c Is Nothing And c.Address <> firstAddress ' Schleife Ende <<--
End If
End With

End Sub
' Eine kleine Hilfe von mir bitte damit einwenig rumspielen um
' zu verstehen was gemacht wird.
'
' In VBA im Bereich diese Arbeitsmappe kopieren
' Auf Excel-ebene unter EXTRAS, MAKRO, MAKROS
' DieseArbeitsmappe -> Makro suchen anklicken und Optionen auswählen
' Buchstabe einsetzen für Tastenkombi z.B. a
' nun steht das Makro mit der gewählten Tastenkombi zur Verfügung

' With Worksheets(Tab1).Range("a1:a500") <-- Worksheets(Tab1).Range("Dein_Bereich") anpassen
' Range("A" + Trim(Str$(c.Row)) + ":G" + Trim(Str$(c.Row))).Select <-- A bis G ändern für die eigene Tabelle


' Sascha Oliver Haak für PPF 2009

[Sascha Oliver Haak]

@Mistertolle

Hallo,

übe mal einwenig mit der Beispieltabelle herum. Habe gerade einen schweren Kopf und bin noch nicht ganz auf den Damm.
Wenn noch probleme bestehen melde Dich.

Gruß
Sascha

[Mistertolle]

Hi!!!!
Sascha Du bist der Held!!!
Genau so und nicht anders wollte ich es haben, Danke

Bis denne.... Marco

[Sascha Oliver Haak]

@Mistertolle

Gerngeschehen. Du weisst ja freundlichen Menschen hilft man gern und
super guten Menschen bietet man die Freundschaft an.

Gruß
Sascha