Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

In Tabelle Suchen und Bereich kopieren - Bitte Hil

In Tabelle Suchen und Bereich kopieren - Bitte Hil
Marc
Hallo,
auch nach ausgiebiger Suche habe ich leider keine Lösung zu meinem Problem gefunden.
Ich möchte aus einem anderen Workbook nach einem bestimmten Text suchen, dies mache ich bislang wie folgt
Dim Zelle as Range
Dim customers as Range
Set customers = Workbooks("Customer - Partno.XLS").Sheets("Customer - Partno").Range("I1:I1000")
For Each Zelle In customers
If Zelle.Value = "7871013640" Then
Zelle.Offset(0, 7).Copy Destination:=Range("A1")
End If
Next
Nun gibt es zu meinem Suchauftrag aber nicht ein, sondern mehrere Ergebisse sprich, es gibt den Wert "7871013640" in diesem Workbook mehrmals, in diesem Fall Suche ich nach einer Kundennummer.
Nun möchte ich gerne alle Ergebnisse, die ich unter berücksichtigung des Offsets, finde in ein anderes Workbook kopieren.
Hier mein Problem in Zahlen zur veranschaulichung:
Kundennr: Partno:
100234 7871013640
100238 7871013640
100245 7871013640
Ich würde mich über eure Hilfe sehr freuen. Danke.
Gruß
Marc

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: In Tabelle Suchen und Bereich kopieren - Bitte Hil
25.06.2009 20:52:35
Josef
Hallo Marc,
so?
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub searchPartNo()
  Dim objTargetWB As Workbook
  Dim rng As Range, rngFind As Range, rngCopy As Range
  Dim strFirst As String, strSearch As String
  
  strSearch = InputBox("Bitte gesuchte Teilenummer eingeben:", "Teilenummer Suchen", "7871013640")
  
  If strSearch = "" Then Exit Sub
  
  Set rngFind = Workbooks("Customer - Partno.XLS").Sheets("Customer - Partno").Range("I1:I1000")
  
  Set objTargetWB = Workbooks("Ziel.xls").Sheets("Zieltabelle") 'Zieldatei/Tabelle - Anpassen
  
  objTargetWB.Range("A:A").ClearContents 'Frühere Ergebnisse in Ziel löschen
  
  Set rng = rngFind.Find(what:=strSearch, LookAt:=xlWhole, LookIn:=xlValues, MatchCase:=False)
  
  If Not rng Is Nothing Then
    strFirst = rng.Address
    Do
      If rngCopy Is Nothing Then
        Set rngCopy = rng.Offset(0, 7)
      Else
        Set rngCopy = Union(rngCopy, rng.Offset(0, 7))
      End If
      Set rng = rngFind.FindNext(rng)
    Loop While Not rng Is Nothing And rng.Address <> strFirst
  End If
  
  If Not rngCopy Is Nothing Then rngCopy.Copy objTargetWB.Range("A1")
  
  Set rng = Nothing
  Set rngCopy = Nothing
  Set rngFind = Nothing
End Sub

Gruß Sepp

Anzeige
AW: In Tabelle Suchen und Bereich kopieren - Bitte Hil
26.06.2009 13:58:14
Marc
Hey Sepp.
Wunderbar vielen Dank für deine schnelle und Kompetente Hilfe.
Hatte kurzzeitig ein Debug "Out of Range" in Zeile
  • Set objTargetWB = Workbooks("Ziel.xls").Sheets("Zieltabelle") 'Zieldatei/Tabelle - Anpassen

  • bekommen. Dann einfach die
    
    objTargetWB
    

    als Range definifert und noch die Wunschrange hinten dran gehängt.
    Arbeite erst seit gut einer Woche mit VBA und dein Code ist gut mal zu sehen wie die Pros es machen :-).
    Wünsche dir ein gutes Wochenende.
    Gruß
    Marc

    AW: In Tabelle Suchen und Bereich kopieren - Bitte Hil
    26.06.2009 15:16:37
    Marc
    Hey Sepp.
    Wunderbar vielen Dank für deine schnelle und Kompetente Hilfe.
    Hatte kurzzeitig ein Debug "Out of Range" in Zeile
  • Set objTargetWB = Workbooks("Ziel.xls").Sheets("Zieltabelle") 'Zieldatei/Tabelle - Anpassen

  • bekommen. Dann einfach die
    
    objTargetWB
    

    als Range definifert und noch die Wunschrange hinten dran gehängt.
    Arbeite erst seit gut einer Woche mit VBA und dein Code ist gut mal zu sehen wie die Pros es machen :-).
    Wünsche dir ein gutes Wochenende.
    Gruß
    Marc

    Anzeige

    326 Forumthreads zu ähnlichen Themen

    Anzeige
    Anzeige
    Anzeige
    Anzeige

    Links zu Excel-Dialogen

    Beliebteste Forumthreads (12 Monate)

    Anzeige

    Beliebteste Forumthreads (12 Monate)

    Anzeige
    Anzeige
    Anzeige