Office Forum
www.Office-Loesung.de
Access :: Excel :: Outlook :: PowerPoint :: Word :: Office :: Wieder Online ---> provisorisches Office Forum <-
Suchfunktion per Makro. Brauche Hilfe bei der Modifikation!
zurück: eingebettetes Label Click Ereignis weiter: sortieren meherer spalten nachinander Unbeantwortete Beiträge anzeigen
Neues Thema eröffnen   Neue Antwort erstellen     Status: Feedback Facebook-Likes Diese Seite Freunden empfehlen
Zu Browser-Favoriten hinzufügen
Autor Nachricht
synt4x
Im Profil kannst Du frei den Rang ändern


Verfasst am:
20. Jan 2013, 22:22
Rufname:

Suchfunktion per Makro. Brauche Hilfe bei der Modifikation! - Suchfunktion per Makro. Brauche Hilfe bei der Modifikation!

Nach oben
       Version: Office 2010

Moin zusammen,

auf der Suche nach einem einfachen Makro zum Durchsuchen eine Tabelle bin ich auf die folgende Seite gestoßen.

http://www.herber.de/forum/archiv/1216to1220/1217118_wert_aus_tabelle_suchen_und_zeile_in_listbox_ausge.html

Ich habe mir eine TextBox ein CommandButton und eine ListBox erstellt, und war hoch erfreut, dass alles funktioniert hat. Um dies nun auch nutzen zu können wie geplant, muss ich allerdings an der einen oder anderen Stelle "modifizieren". Dummerweise stoße ich hier schon an meine Grenzen.

Hier erstmal der Code:
(Zeilen, die ich m.E. nicht benötige habe ich ausdokumentiert.)

Code:
 Private Sub CommandButton1_Click() 'Anpassen
 'Button Suchen
 
 Dim s As String
 Dim Found As Range
 Dim FirstAddress As String
 Dim I As Integer ' Zeile
 On Error Resume Next
 I = 0
 
 s = Trim(TextBox1.Text) 'Sucheingabe über Textbox1 steuern
 If s = "" Then Exit Sub
 ListBox1.Clear
 With ActiveSheet
 
   Set Found = .Cells.Find(what:=s, LookAt:=xlPart)
 
  If Not Found Is Nothing Then
    FirstAddress = Found.Address
    'ListBox1.ColumnCount = 10 'Gibt die Werte der gefundenen Treffer an (Spaltenbezogen)
    Do
      ListBox1.AddItem Found
      'ListBox1.List(I, 1) = Cells(Found.Row, 4)
      'ListBox1.List(I, 2) = Cells(Found.Row, 6)
      'ListBox1.List(I, 3) = Cells(Found.Row, 7)
      'ListBox1.List(I, 4) = Cells(Found.Row, 8)
      'ListBox1.List(I, 5) = Cells(Found.Row, 9)
      Set Found = Cells.FindNext(after:=Found)
      If Found.Address = FirstAddress Then Exit Do
      I = I + 1
    Loop
   
  End If
  End With
End Sub


Ich würde das Makro gern folgendermaßen abändern:

[*] Ich möchte gern ein anderes Tabellenblatt duchsuchen. Nach Möglichkeit auch nur eine Spalte. Das Ersetzen von "with ActiveSheet" durch "with sheets ("Tabelle2") läuft in Leere. Embarassed

[*] Es wäre sehr hilfreich, wenn ich per Doppelklick auf ein Suchergebnis in der ListBox diesen Eintrag an eine Zelle übergeben könnte.

[*] Die Bedienung der Suchfunktion wäre komfortabler, wenn ich die Suche mit "Enter" anstoßen könnte. Mein Bauch sagt mir aber, dass das schwierig zu realisieren ist. Stimmt das?

Habt Ihr evtl. einen Tipp für mich, der mich der finalen Lösung näher bringt?
Bin für jeden Hinweis dankbar, aber bitte anfängerkompatibel. Stecke leider nicht wirklich in der Materie. Crying or Very sad

Vielen Dank vorab!

synt4x
Nicolaus
Hobby-VBAler


Verfasst am:
20. Jan 2013, 23:55
Rufname: Nic
Wohnort: Rhein Main Gebiet


AW: Suchfunktion per Makro. Brauche Hilfe bei der Modifikati - AW: Suchfunktion per Makro. Brauche Hilfe bei der Modifikati

Nach oben
       Version: Office 2010

Hi,

für das with braucht es auch vor dem "Cells" bei "FindNext" einen Punkt,
wenn du die auskommentierten Zeilen brauchst, dann auch dort.

Die Eingabe von Enter kannst du beispielsweise im Keydown.Event der Listbox abfragen:
Code:
Private Sub TextBox1_Keydown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
    Case 13
        KeyCode = 0       
        Dim s As String, FirstAddress As String
        Dim Found As Range, I As Integer ' Zeile
        'On Error Resume Next
        I = 0
        s = Trim(TextBox1.Text) 'Sucheingabe über Textbox1 steuern
        If s = "" Then Exit Sub
        ListBox1.Clear
        With Sheets("Tabelle2")
            Set Found = .Cells.Find(what:=s, LookAt:=xlPart)
            If Not Found Is Nothing Then
                FirstAddress = Found.Address
                'ListBox1.ColumnCount = 10 'Gibt die Werte der gefundenen Treffer an (Spaltenbezogen)
                Do
                    ListBox1.AddItem Found
                    'ListBox1.List(I, 1) = .Cells(Found.Row, 4)
                    'ListBox1.List(I, 2) = .Cells(Found.Row, 6)
                    'ListBox1.List(I, 3) = .Cells(Found.Row, 7)
                    'ListBox1.List(I, 4) = .Cells(Found.Row, 8)
                    'ListBox1.List(I, 5) = .Cells(Found.Row, 9)
                    Set Found = .Cells.FindNext(after:=Found)
                    If Found.Address = FirstAddress Then Exit Do
                    I = I + 1
                Loop
            End If
        End With
    End Select
End Sub

und so den Doppelklick:
Code:
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    MsgBox ListBox1.Text
End Sub
Gruss
Nic

_________________
die Forenhelfer freuen sich über eine Antwort
synt4x
Im Profil kannst Du frei den Rang ändern


Verfasst am:
21. Jan 2013, 00:35
Rufname:

AW: Suchfunktion per Makro. Brauche Hilfe bei der Modifikati - AW: Suchfunktion per Makro. Brauche Hilfe bei der Modifikati

Nach oben
       Version: Office 2010

Hi Nic,

vielen Dank.
Eingabe mit Enter und die Abfrage funktionieren tadellos. RESPEKT!

Die Übergabe an eine Zelle per Doppelklick funktioniert leider nicht so wie ich mir das vorgestellt habe. Es öffnet sich lediglich eine MessageBox...

Wenn wir, oder vielmehr Ihr, den letzten Schritt noch lösen könntet, wäre mir sehr geholfen.

Gute Nacht & Besten Dank!
synt4x
Nicolaus
Hobby-VBAler


Verfasst am:
21. Jan 2013, 01:02
Rufname: Nic
Wohnort: Rhein Main Gebiet

AW: Suchfunktion per Makro. Brauche Hilfe bei der Modifikati - AW: Suchfunktion per Makro. Brauche Hilfe bei der Modifikati

Nach oben
       Version: Office 2010

Hi,

ja, war ja auch nur ein Beispiel für die Doppelklickabfrage.
Ohne zu wissen wo du es hinschreiben willst, ist das etwas schwierig.
Hier mal als Beispiel für A1 in Tabelle1:
Code:
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Sheets("Tabelle1").Cells(1, 1) = ListBox1.Text
End Sub
Gruss
Nic

_________________
die Forenhelfer freuen sich über eine Antwort
synt4x
Im Profil kannst Du frei den Rang ändern


Verfasst am:
21. Jan 2013, 09:17
Rufname:

AW: Suchfunktion per Makro. Brauche Hilfe bei der Modifikati - AW: Suchfunktion per Makro. Brauche Hilfe bei der Modifikati

Nach oben
       Version: Office 2010

Super!

Vielen Dank!
Hab noch nicht ausprobiert, wird aber sicherlich funktionieren.

Gruß!
synt4x
synt4x
Im Profil kannst Du frei den Rang ändern


Verfasst am:
22. Jan 2013, 21:16
Rufname:


AW: Suchfunktion per Makro. Brauche Hilfe bei der Modifikati - AW: Suchfunktion per Makro. Brauche Hilfe bei der Modifikati

Nach oben
       Version: Office 2010

Moin Nic, vielen Dank nochmal für die untertützung. Auch das 2.Sub funktioniert.

Aber jetzt kommt der Gesamtcode ins stocken, und an diesem Punkt bin nun absolut ratlos.

Zur Erklärung:

Ich habe ein template, das mit verschiedenen Informationen gefüllt wird u.a. auch mit hilfe der Suchfunktion, bei der Du mir so professionell geholfen hast.

Also ich habe auf dem ersten Tabellenblatt 3 Bereiche, zu jedem Bereich gibt es einen Button der mit einem Sub verknüpft ist, welches wiederum eine Funktion aufruft. Ich markiere so einen Bereich des Templates wandle ihn mit der Funktion in HTML und übergebe diesen Ausschnitt dann an Outlook.

Wenn ich nun die eine Zelle mit dem Ergebnis der suchfunktion fülle, stürzt mir das Makro ab. Vielleicht ist die Lösung ja recht simpel?

Ich füge hier mal den Code ein.


Code:
Public Sub prcSendRange1()
    Dim objOutlook As Object, objMail As Object
    Set objOutlook = CreateObject(Class:="Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)
    With objMail
        .To = Range("e2").Value
        .cc = Range("e3").Value
        .Subject = Range("E28").Value
        .HTMLBody = fncRangeToHtml("c5:k25", "template")
        .Display
'        .Send
    End With
    Set objMail = Nothing
    Set objOutlook = Nothing
End Sub

Public Sub prcSendRange2()
    Dim objOutlook As Object, objMail As Object
    Set objOutlook = CreateObject(Class:="Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)
    With objMail
        .To = Range("e2").Value
        .cc = Range("e3").Value
        .Subject = "Blabla"
        .HTMLBody = fncRangeToHtml("c25:k35", "template")
        .Display
'        .Send
    End With
    Set objMail = Nothing
    Set objOutlook = Nothing
End Sub

Public Sub prcSendRange3()
    Dim objOutlook As Object, objMail As Object
    Set objOutlook = CreateObject(Class:="Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)
    With objMail
        .To = Range("e2").Value
        .cc = Range("e3").Value
        .Subject = "BlaBlaBla" & Range("G37").Value & " BlaBlaBla"
        .HTMLBody = fncRangeToHtml("C35:k51", "template")
        .Display
'        .Send
    End With
    Set objMail = Nothing
    Set objOutlook = Nothing
End Sub

Private Sub TextBox1_Keydown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
    Case 13
        KeyCode = 0
        Dim s As String, FirstAddress As String
        Dim Found As Range, I As Integer ' Zeile
        'On Error Resume Next
        I = 0
        s = Trim(TextBox1.Text) 'Sucheingabe über Textbox1 steuern
        If s = "" Then Exit Sub
        ListBox1.Clear
        With Sheets("Fehlernummern")
            Set Found = .Cells.Find(what:=s, LookAt:=xlPart)
            If Not Found Is Nothing Then
                FirstAddress = Found.Address
                'ListBox1.ColumnCount = 10 'Gibt die Werte der gefundenen Treffer an (Spaltenbezogen)
                Do
                    ListBox1.AddItem Found
                    'ListBox1.List(I, 1) = .Cells(Found.Row, 4)
                    'ListBox1.List(I, 2) = .Cells(Found.Row, 6)
                    'ListBox1.List(I, 3) = .Cells(Found.Row, 7)
                    'ListBox1.List(I, 4) = .Cells(Found.Row, 8)
                    'ListBox1.List(I, 5) = .Cells(Found.Row, 9)
                    Set Found = .Cells.FindNext(after:=Found)
                    If Found.Address = FirstAddress Then Exit Do
                    I = I + 1
                Loop
            End If
        End With
    End Select
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Sheets("template").Cells(7, 6) = ListBox1.Text
End Sub

'**************************************************
'* H. Ziplies                                     *
'* 12.11.12                                       *
'* erstellt von HajoZiplies@web.de                *
'* http://Hajo-Excel.de/                          *
'**************************************************


Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
    Dim RaBereich As Range                          ' Varable Bereich Wirksamkeit
    ' von Nepumuk Anzahl der ausgewählten Zellen
    If CallByName(Selection, IIf(Val( _
        Application.Version) > 11, "CountLarge", "Count"), VbGet) = 1 Then
        ' Bereich der Wirksamkeit
        Set RaBereich = Range("g38")
        ' noch mehr Bereiche
        'Set RaBereich = Union(Range("C11:AG11 , C13:AG13, C15:AG15 , C17:AG17"), _
            Range("C35:AE35, C37:AE37, C43:AG43, C45:AG45 , C47:AG47 , C49:AG49"), _
            Range("C67:AF67 , C69:AF69 , C75:AG75 , C77:AG77 , C79:AG79 , C81:AG81"), _
            Range("C99:AF99 , C101:AF101, C107:AG107 , C109:AG109 , C111:AG111"), _
            Range("C127:AG127 , C129:AG129 , C131:AG131 , C133:AG133 , C139:AF139"), _
            Range("C155:AG155, C157:AG157 , C159:AG159 , C161:AG161 , C163:AG163"), _
            Range("C179:AF179 , C181:AF181, C187:AG187 , C189:AG189 , C191:AG191"))
        'ActiveSheet.Unprotect ("Passwort")  ' Schutz der Tabelle aufheben
        ' prüfen ob Zelle im Bereich, dann Userform starten
        If Not Intersect(Target, RaBereich) Is Nothing Then
            'ActiveSheet.unprotect ("Passwort")     ' Schutz auf Tabelle setzen
            frm_Kalender.Show
            'ActiveSheet.protect ("Passwort")       ' Schutz auf Tabelle setzen
        End If
        Set RaBereich = Nothing                     ' Variable löschen
    End If
End Sub



Private Function fncRangeToHtml(strRange As String, strSheetname As String) As String
    Dim objFilesytem As Object, objTextstream As Object
    Dim strFilename As String
    strFilename = Environ$("temp") & "/" & _
        Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    ActiveWorkbook.PublishObjects.Add( _
        SourceType:=xlSourceRange, _
        Filename:=strFilename, _
        Sheet:=strSheetname, _
        Source:=strRange, _
        HtmlType:=xlHtmlStatic).Publish True
    Set objFilesytem = CreateObject("Scripting.FileSystemObject")
    Set objTextstream = objFilesytem.GetFile(strFilename). _
        OpenAsTextStream(1, -2)
    fncRangeToHtml = objTextstream.ReadAll
    objTextstream.Close
    Set objTextstream = Nothing
    Set objFilesytem = Nothing
    Kill strFilename
End Function



Nach dem "prcSendRange3()" steigt das Makro aus.
woran kann das liegen? Ich bin kurz vorm Abschluss, und hoffe Du kannst helfen.

Regards & Besten Dank vorab!
synt4x
Neues Thema eröffnen   Neue Antwort erstellen Alle Zeiten sind
GMT + 1 Stunde

Diese Seite Freunden empfehlen

Seite 1 von 1
Gehe zu:  
Du kannst Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
Du kannst Dateien in diesem Forum nicht posten
Du kannst Dateien in diesem Forum herunterladen

Verwandte Themen
Forum / Themen   Antworten   Autor   Aufrufe   Letzter Beitrag 
Keine neuen Beiträge Excel Formeln: komplexe Suchfunktion für Halbwertszeit 3 Gast Natalie 715 24. Okt 2005, 14:14
ae komplexe Suchfunktion für Halbwertszeit
Keine neuen Beiträge Excel Formeln: Shortcuts ändern oder in ein Makro einbinden? 0 Tobstar 5683 10. Okt 2005, 18:34
Tobstar Shortcuts ändern oder in ein Makro einbinden?
Keine neuen Beiträge Excel Formeln: brauche dringend hilfe **Wahlergebnisse in Excel*editiert ae 11 Sunni 1272 24. Sep 2005, 20:13
ae brauche dringend hilfe **Wahlergebnisse in Excel*editiert ae
Keine neuen Beiträge Excel Formeln: Makro einbinden 1 danyboy 856 03. Jun 2005, 15:50
fl618 Makro einbinden
Keine neuen Beiträge Excel Formeln: brauche eine "Wenn-Formel" 2 Verlorener Held 626 20. Mai 2005, 12:26
Verlorener Held brauche eine "Wenn-Formel"
Keine neuen Beiträge Excel Formeln: Formel oder Makro??? 4 Karlito 1259 16. Mai 2005, 13:10
Gast Formel oder Makro???
Keine neuen Beiträge Excel Formeln: Makro per Button ausführen lassen und if then problem 5 Darwin 3876 09. Mai 2005, 14:57
Darwin Makro per Button ausführen lassen und if then problem
Keine neuen Beiträge Excel Formeln: Endlos Makro 5 Jericho2000 1369 15. Apr 2005, 10:17
c0bRa Endlos Makro
Keine neuen Beiträge Excel Formeln: Formulartextfelderinhalt per Button in anderes Tabellenblatt 3 Blubberbernd 1232 10. Apr 2005, 10:49
fl618 Formulartextfelderinhalt per Button in anderes Tabellenblatt
Keine neuen Beiträge Excel Formeln: Suchfunktion im Excel 8 McBrumm 8297 04. Apr 2005, 17:00
McBrumm Suchfunktion im Excel
Keine neuen Beiträge Excel Formeln: Ich brauche mal ne Formel 3 Kiamolo 495 20. Jan 2005, 15:57
Gast Ich brauche mal ne Formel
Keine neuen Beiträge Excel Formeln: Ich brauche eine Formel und bitte um hilfe 11 freddy-krueger 584 03. Jan 2005, 13:20
Charly2 Ich brauche eine Formel und bitte um hilfe
 

----> Diese Seite Freunden empfehlen <------ Impressum - Besuchen Sie auch: HTML Forum