Hilfe für Vergleichen - einfügen

Forumthread: Hilfe für Vergleichen - einfügen

12.06.2015 09:17:37

Peter

Guten Morgen
ich benötige wieder einmal die Hilfe der Fachleute.
Ich habe eine Excel-Datei mit vier Tabellen. In der 1. sind alle Codes vorhanden.
In der 2. bestimmte ausgewählte Codes. Nun sollen die Codes, die in diesen beiden
Tabellen vorhanden sind und in Anzahl Wert vorhanden ist mit Code und Anzahl der Reihe nach in die Tabelle 3 eingefügt werden. Die aus der Tabelle 2, die nicht mit der Tabelle 1 identisch sind und die keinen Wert bei Anzahl aufweisen, sollen
in die Tabelle 4 eingefügt werden.
Besten Dank für Eure Hilfe.
Noch ein Hinweis: Die Tabellen 1 und 2 sind unterschiedlich lang, je nachdem, was
eingespielt wird.
https://www.herber.de/bbs/user/98159.xlsm
Gruss
Peter

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Hilfe für Vergleichen - einfügen

12.06.2015 20:31:27

Sepp
AW: Hilfe für Vergleichen - einfügen

13.06.2015 13:03:30

Peter

AW: Hilfe für Vergleichen - einfügen

12.06.2015 20:31:27

Sepp

Hallo Peter,
per VBA.

' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub compare()
  Dim varAll As Variant, varChoosen As Variant, varError() As Variant, varIdentic() As Variant
  Dim lngN As Long, lngI As Long, lngE As Long
  Dim vntR As Variant
  
  With Sheets("Tabelle1_alle")
    varAll = .Range("A2:A" & Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row))
  End With
  
  With Sheets("Tabelle2_gewählte")
    varChoosen = .Range("A2:B" & Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row))
  End With
  
  Sheets("Tabelle4_Fehler").Range("A2:B1000") = ""
  Sheets("Tabelle3_identisch").Range("A2:B1000") = ""
  
  
  For lngN = 1 To UBound(varChoosen, 1)
    If varChoosen(lngN, 1) <> "" Then
      vntR = Application.Match(varChoosen(lngN, 1), varAll, 0)
      If IsError(vntR) Or varChoosen(lngN, 2) = "" Then
        Redim Preserve varError(lngE)
        varError(lngE) = Array(varChoosen(lngN, 1), varChoosen(lngN, 2))
        lngE = lngE + 1
      End If
      If Not IsError(vntR) And varChoosen(lngN, 2) <> "" Then
        Redim Preserve varIdentic(lngI)
        varIdentic(lngI) = Array(varChoosen(lngN, 1), varChoosen(lngN, 2))
        lngI = lngI + 1
      End If
    End If
  Next
  
  If lngI > 0 Then _
    Sheets("Tabelle4_Fehler").Range("A2").Resize(UBound(varError) + 1, 2) = _
    Application.Transpose(Application.Transpose(varError))
  
  If lngE > 0 Then _
    Sheets("Tabelle3_identisch").Range("A2").Resize(UBound(varIdentic, 1) + 1, 2) = _
    Application.Transpose(Application.Transpose(varIdentic))
  
  
End Sub

Gruß Sepp

AW: Hilfe für Vergleichen - einfügen

13.06.2015 13:03:30

Peter

Hallo Sepp,
besten Dank für Deine schnelle und vorallem funktionierende Hilfe.
Habe Makro gerade ausprobiert funktioniert bestens.
Wünsche ein schönes Wochenende.
Gruss Peter

Beliebteste Forumthreads (12 Monate)

Hilfe für Vergleichen - einfügen

Forumthread: Hilfe für Vergleichen - einfügen

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread