PLZ selektieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: PLZ selektieren

25.03.2008 10:52:57

Peter Feustel

AW: PLZ selektieren

25.03.2008 12:37:06

sascha

AW: PLZ selektieren

25.03.2008 14:23:04

Peter Feustel

AW: PLZ selektieren

25.03.2008 14:48:39

sascha

AW: PLZ selektieren

25.03.2008 15:24:46

Peter Feustel

Hallo Sascha,
so könnte es gehen.
Annahmen: Die Pstlz stht in Tabelle1/Tabelle2 in Spalte A ab Zeile 1
Die zu übertragenden Werte in Tabelle2 stehen in Spalte A - Z

Option Explicit
Public Sub Vergleichen()
Dim Wksh_1    As Worksheet  ' das Quell-Tabellenblatt - die Such-Pstlz
Dim Wksh_2    As Worksheet  ' das Quell-Tabellenblatt - die Herkunft der Daten
Dim Wksh_3    As Worksheet  ' das  Ziel-Tabellenblatt - die Ausgabe-Tabelle
Dim lZeile_1  As Long       ' der Zeilen-Index im Such-Tabellenblatt
Dim lZeile_3  As Long       ' der Zeilen-Index im Ziel-Tabellenblatt
Dim rZelle    As Range      ' die Fundzelle
Dim sFundst   As String     ' die erste Fundstelle
   Application.ScreenUpdating = False ' kein Bildschirm-Update erlauben
   Set Wksh_1 = Worksheets("Tabelle1")
   Set Wksh_2 = Worksheets("Tabelle2")
   Set Wksh_3 = Worksheets("Tabelle3")
   For lZeile_1 = 1 To Wksh_1.Cells(Rows.Count, 1).End(xlUp).Row ' suchen ab Zeile 1
      With Wksh_2.Columns(1)              ' suchen in Spalte 1 = A
         Set rZelle = .Find(Wksh_1.Cells(lZeile_1, 1).Value, LookAt:=xlWhole, LookIn:=xlValues)
         If Not rZelle Is Nothing Then    ' wurde der Suchbegriff gefunden ?
            sFundst = rZelle.Address      ' die erste Fundstelle merken/speichern
            Do                            ' Iteration starten
               lZeile_3 = lZeile_3 + 1    ' den Zeilenzähler um 1 erhöhen
'                in die Spalte A der Ziel-Tabelle, die Zeile aus der Quell-Tabelle übertragen
               Wksh_2.Range(Cells(rZelle.Row, 1), Cells(rZelle.Row, 26)).Copy Destination:= _
               Wksh_3.Cells(lZeile_3, 1)
               Set rZelle = .FindNext(rZelle) ' die ggf. nächste Fundstelle akquirieren
'                solange suchen, bis nichts mehr gefunden wird,
'                oder die erste Fundstelle wieder erreicht ist.
            Loop While Not rZelle Is Nothing And rZelle.Address <> sFundst
          'Else                            ' sonst, bei NICHT gefunden, eine Nachricht ausgeben
          '  MsgBox "Der Begriff  """ & sSuchbegr & """  wurde nicht gefunden.", _
          '     48, "   Hinweis für " & Application.UserName
         End If
      End With
   Next lZeile_1  ' die nächste Such-Pstlz
   Application.ScreenUpdating = True  ' den Bildschirm-Update wieder zulassen
End Sub

Code eingefügt mit Syntaxhighlighter 4.4

Gruß Peter

Beliebteste Forumthreads (12 Monate)

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

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread