Tipp 0120 Datensätze suchen und kopieren
Autor/Einsender:
Datum:
  Angie
06.03.2005 (Update)
Entwicklungsumgebung:   Excel 2000
Sollen bestimmte Datensätze gefiltert und auf andere Tabellenblätter übertragen werden, kann man entweder die Tabellen Zeile für Zeile abarbeiten oder aber, vor allem bei größeren Datenbeständen (mehrere tausend Zeilen), mit der Find-/FindNext-Methode arbeiten.
Die Find-Methode sucht bestimmte Informationen in einem Bereich und gibt ein Range-Objekt zurück, das die erste Zelle mit diesem Inhalt darstellt. Mit der FindNext-Methode wird die Suche mit den selben Suchkriterien fortgesetzt. Hier ist zu beachten, dass wenn das Ende des Suchbereichs erreicht wurde, erneut am Anfang mit der Suche begonnen wird (Endlosschleife). Um dies zu verhindern, wird die Adresse der ersten gefundenen Zelle gespeichert und mit den nachfolgend gefundenen Zelladressen verglichen.
In diesem Beispiel wird überprüft, ob die zu vergleichenden Daten in Tabelle 'Daten2' in der Tabelle 'Daten1' vorhanden sind (hier jeweils nur Vergleich der Zellen der ersten Spalte). Je nachdem, ob die Datensätze vorhanden/nicht vorhanden sind, wird die entsprechende Zeile in die jeweilige Ziel-Tabelle kopiert.
Code im Codebereich des Moduls
 
Option Explicit

Private Const mc_MsgTitle As String = "VB-fun-Demo"

Private Function CompareDataWithFindNext( _
            ByVal objWksData1 As Worksheet, _
            ByVal objWksData2 As Worksheet, _
            ByVal objWkbAddWksTo As Workbook) As Boolean

  Const cstrWksFound    As String = "DatenInTab1UndTab2"
  Const cstrWksMissing  As String = "DatenInTab2NichtInTab1"

  Dim objWksDataFound   As Worksheet
  Dim objWksDataMissing As Worksheet

  Dim nRow        As Long
  Dim nRowsCnt    As Long
  Dim nRowsF      As Long
  Dim nRowsM      As Long

  Dim strFind     As String
  Dim objRngCell  As Range
  Dim strCellAdr  As String

  On Error GoTo err_CompareData

  Application.ScreenUpdating = False

  With objWksData2
      nRowsCnt = .Cells(.Rows.Count, 1).End(xlUp).Row
  End With
  If nRowsCnt < 2 Then
      Err.Raise vbObjectError + 513
  End If

  Set objWksDataFound = AddWorksheet(objWkbAddWksTo, _
        cstrWksFound)
  objWksData1.Rows(1).EntireRow.Copy _
        Destination:=objWksDataFound.Cells(1, 1)

  Set objWksDataMissing = AddWorksheet(objWkbAddWksTo, _
        cstrWksMissing)
  objWksData1.Rows(1).EntireRow.Copy _
        Destination:=objWksDataMissing.Cells(1, 1)

  nRowsF = 2
  nRowsM = 2

  For nRow = 2 To nRowsCnt
    strFind = objWksData2.Cells(nRow, 1).Value

    With objWksData1.Columns(1)
      Set objRngCell = .Find(strFind, LookIn:=xlValues, _
            LookAt:=xlWhole)

      If objRngCell Is Nothing Then
        objWksData2.Rows(nRow).EntireRow.Copy _
              Destination:=objWksDataMissing.Cells(nRowsM, 1)

        nRowsM = nRowsM + 1

      Else
        strCellAdr = objRngCell.Address
        Do
          objWksData1.Rows(objRngCell.Row).EntireRow.Copy _
                Destination:=objWksDataFound.Cells(nRowsF, 1)

          nRowsF = nRowsF + 1

          Set objRngCell = .FindNext(objRngCell)
        Loop While (Not objRngCell Is Nothing) And _
              (objRngCell.Address <> strCellAdr)
      End If
    End With
  Next

  objWksDataFound.Activate
  CompareDataWithFindNext = True

exit_Func:
  On Error GoTo 0

  Set objWksData1 = Nothing
  Set objWksData2 = Nothing
  Set objWksDataFound = Nothing
  Set objWksDataMissing = Nothing
  Set objWkbAddWksTo = Nothing

  Application.ScreenUpdating = True
  Exit Function

err_CompareData:
  Select Case Err.Number
    Case vbObjectError + 513
      MsgBox "Keine Daten zum Vergleich!", _
            vbInformation, mc_MsgTitle

    Case Else
      MsgBox Err.Description, vbCritical, mc_MsgTitle
  End Select
  Resume exit_Func
End Function

Private Function AddWorksheet(ByVal objWkb As Workbook, _
      ByVal sWksName As String) As Worksheet

  On Error Resume Next
  Dim objWks As Worksheet

  With objWkb
    Application.DisplayAlerts = False
    objWkb.Worksheets(sWksName).Delete
    Application.DisplayAlerts = True

    Set objWks = objWkb.Worksheets.Add( _
          After:=.Worksheets(.Worksheets.Count))
    objWks.Name = sWksName
    Set AddWorksheet = objWks
  End With

  Set objWks = Nothing
  Set objWkb = Nothing
  On Error GoTo 0
End Function
 
Beispiel-Aufruf
 
Public Sub CompareDataInWorksheets()
  On Error GoTo err_CompareWks

  If CompareDataWithFindNext(ActiveWorkbook.Worksheets(1), _
          ActiveWorkbook.Worksheets(2), ActiveWorkbook) Then

    MsgBox "Der Vergleich wurde erfolgreich durchgeführt!", _
          vbInformation, mc_MsgTitle
  End If

exit_Sub:
  On Error GoTo 0
  Exit Sub

err_CompareWks:
  MsgBox Err.Description, vbCritical, mc_MsgTitle
  Resume exit_Sub
End Sub
 

Windows-Version
95
98/SE
ME
NT
2000
XP
Vista
Win 7
Excel-Version
95
97
2000
2002 (XP)
2003
2007
2010


Download  (17,7 kB) Downloads bisher: [ 2974 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Sonntag, 8. Mai 2011