PDA

Vollständige Version anzeigen : Vergleich von Werten zweier Excelsheets!


AlexF.
15.01.2014, 16:07
Es ist nicht zwingend ein VBA code nötig, ich glaub das geht auch gut über Formeln in Excel!
Im Anhang hab ich eine Beispieldatei mit Tabelle1 und Tabelle2 und dem gewünschten Ergebnis in Tabelle3. Mit Erklärung dazu! Ein Text ist viel zu kompliziert, die Datei erklärt das eigentlich am besten, aber ich schreib trotzdem mal einen Text, einfach nur lesen wenn die Datei es nicht genug erklärt :)

Prüfe ob der Inhalt, der in Tabelle1 in SpalteB steht, auch in Tabelle2 in SpalteB zu finden ist.
Gibt es keine Zeile auf die das Zutrifft, dann prüfe die nächste Zelle aus Tabelle1 SpalteB.

Gibt es Zeilen auf die das Zutrifft, Beispielsweise in Tabelle1 B5=202; in Tabelle2 B10=202,
dann Prüfe weiter ob diese Zeilen gleichzeitig auch eine Übereistimmung in Spalte A aufzeigen, Beispielsweise in Tabelle1 A5=w B5=202; in Tabelle2 A10=w B10=202!

Gibt es nur eine Zeile auf die das zutrifft also hier die Zeile5 aus Tabelle1 mit Zeile10 aus Tabelle2, dann schreibe diese beiden Zeilen untereinander (erst die aus Tabelle1, dann die aus Tabelle2) in Tabelle3 in die ersten beiden freien Zeilen.

Gibt es mehrere Zeilen mit ein und dem selben Inhalt in SpalteB sowohl in Tabelle1 als auch in Tabelle2 aber mit mehreren varianten von Inhalten in SpalteA, dann Vergleiche die Zahl jeder übereinstimmenden Zeile aus Tabelle1SpalteC mit der dazugehörigen Zeile aus Tabelle2SpalteC.

Schreibe die beiden Zeilen der Tabellen(gleicher Wert SpalteA und SpalteB) in Tabelle3 untereinander in die ersten freien Zeilen, die hinsichtlich dieses Zahlenwertes die kleinste Differenz haben.

Es hört sich viel komplizierter an als es ist glaub ich 

Danke schon mal, ich hoffe mir kann jmd helfen :)

aloys78
16.01.2014, 11:08
Hallo Alex,

kann es auch eine VBA-Lösung sein ?

Wenn ja, dann habe ich noch Fragen:
- wie sind die Daten in Tabelle 1 und 2 sortiert ?
- können für eine Kombination, zB "x 202", in einer Datei mehrere Zeilen auftreten ?
- was ist zu tun, wenn mehrere Kombinationen, zB "x 202" und "w 202" die gleiche Differenz aufweisen ?

Gruß
Aloys

AlexF.
16.01.2014, 11:55
Hallo Aloys,

Danke für deine Hilfe!

Zu deiner 1. Frage: Nein es gibt defintitiv nur einmal die Kompination x202 in einem Tabellenblatt.
Zu deiner 2. Frage: Falls die Differenz von zB x202 und w202 unter den Tabellen die gleiche Differenz aufweist,
dann soll die Kombination gewählt werden, welche in Tabelle 1 den kleinsten Wert in Spalte C hat.

Beispiel: Tabelle1: x202 in SpalteC den Wert: 0,1
Tabelle1: w202 in SpalteC den Wert 0,2
Tabelle2: x202 in SpalteC den Wert 0,11
Tabelle2: w202 in SpalteC den Wert 0,21

Die Differenz ist wie man sehen kann unter den x202´s und w202´s jeweils 0,01.
Es ist hier also x202 mit 0,1 zu wählen, da dieser kleiner ist als w202.

Liebe Grüße
Alex

aloys78
16.01.2014, 21:08
Hallo Alex,

anbei mein Vorschlag in deiner Beispiel-Mappe:

71846

Gruß
Aloys

AlexF.
17.01.2014, 15:11
Hallo Aloys.

VIELEN VIELEN DANK Für den Code!
Hab mal meine Original Werte in die Beispieldatei kopiert und Nach Fehlermeldungen geschaut, aber es kommen keine. Er funktioniert Einwandfrei. Ich hoffe dass der Code in der Originaldatei auch so wunderbar funktioniert :) das wäre super!!! Ich werde es am Montag gleich ausprobieren und dann Rückinfo geben! Fürs erste wirklich VIELEN DANK !!!

LG Alex

AlexF.
20.01.2014, 14:07
Hallo,

Also, ich habe noch ein Problem in meiner Originaldatei.

Momentan ist der Code so geschrieben, dass bei entsprechender Prüfung,
die Werte aus Tabelle1 (A:C) und die Werte aus Tabelle2 (A:C) in die Tabelle3 untereinander kopiert werden.

Kann man den Code so schreiben, dass bei entsprechender Prüfung,
die Werte aus Tabelle1 (A:J) und die Werte aus Tabelle2 (A:J) in die Tabelle3 untereinander kopiert werden.

Ich habe versucht durch den Code durchzusteigen und das selbst abzuändern allerdings krieg ich es nicht hin ;(

Wäre super wenn du mir nochmal helfen könntest :)

LG Alex

aloys78
20.01.2014, 18:12
Hallo Alex,

anbei den entsprechend abgeänderten Code. Bitte den im Modul enthaltenen Code komplett gegen diesen hier austauschen.

Gruß
Aloys

Option Explicit
Option Base 1

'Version 2 vom 20.01.2014

Sub Vergleichen()
Dim LoLetzte1 As Long 'Letzte belegte Zeile in Tabelle1 1
Dim LoLetzte2 As Long 'Letzte belegte Zeile in Tabelle1 2
Dim LoLetzte As Long
Dim arr() 'Array zum Sammeln der Daten
Dim arr2() 'Array für Ergebnsi
Dim a As Long 'Index für Array arr
Dim a2 As Long 'Index für Array arr2
Dim ws As Worksheet
Dim ws1 As Worksheet 'Worksheet Tabelle 1
Dim ws2 As Worksheet 'Worksheet Tabelle 2
Dim r As Long 'Zeilen#
Dim i As Integer 'Schleifenzähler 'V2
Dim w As Long 'Nr Worksheet
Dim zNr

'=============================================================================
'Initialisieren
'=============================================================================
Set ws1 = Worksheets("Tabelle1")
Set ws2 = Worksheets("Tabelle2")
LoLetzte1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
LoLetzte2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
ReDim arr(1 To LoLetzte1 + LoLetzte2, 1 To 13) 'V 2
'Merkmal 1, Merkmal 2 (Zahl), Menge, Sp d - J, Datei, Differenz, Auswahlzeichen 'V 2

'==============================================================================
'Laden Array
'==============================================================================
a = 0
For w = 1 To 2
If w = 1 Then
Set ws = ws1
LoLetzte = LoLetzte1
Else
Set ws = ws2
LoLetzte = LoLetzte2
End If
For r = 1 To LoLetzte
a = a + 1
arr(a, 11) = w 'Datei 1 oder 2 'V 2
With ws
arr(a, 1) = .Range("A" & r) 'Merkmal 1 - Buchstabe
arr(a, 2) = .Range("B" & r) 'Merkmal 2 - Zahl
arr(a, 3) = .Range("C" & r) 'Menge
For i = 4 To 10 'Spaltenwerte D - J 'V 2
arr(a, i) = .Cells(r, i) 'V 2
Next i 'V 2
arr(a, 12) = 0 'Grundstellung Differenz 'V 2
arr(a, 13) = 0 'Grundstellung Auswahlzeichen 'V 2
End With
Next r
Next w
LoLetzte = LoLetzte1 + LoLetzte2
#If Test = 1 Then 'Parameter wird unter 'Eigenschaften von VBA-Projekt' definiert
Worksheets("Tabelle4").Range("A:BQ").ClearContents 'V 2
Worksheets("Tabelle4").Range("A1:M" & LoLetzte) = arr 'Test 1 'V 2
#End If

'==============================================================================
'Sortieren Array nach Zahl, Buchstabe, Datei
'==============================================================================
Call BubbleSort(arr, UBound(arr), 11, 1) 'V 2
Call BubbleSort(arr, UBound(arr), 1, 1)
Call BubbleSort(arr, UBound(arr), 2, 1)
#If Test = 1 Then
Worksheets("Tabelle4").Range("O1:AA" & LoLetzte) = arr 'Test 2 'V 2
#End If

'===============================================================================
'Vergleichen
'===============================================================================
a2 = 0
For a = 1 To UBound(arr) - 1
If arr(a, 2) = arr(a + 1, 2) And arr(a, 1) = arr(a + 1, 1) Then
If arr(a, 11) = arr(a + 1, 11) Then 'V 2
MsgBox "In Tabelle " & arr(a, 11) & " ist " & arr(a, 1) & " " & arr(a, 2) & "doppelt !", vbCritical 'V 2
Exit Sub
End If
arr(a, 12) = Abs(arr(a, 3) - arr(a + 1, 3)) 'Differenz 'V 2
arr(a + 1, 12) = arr(a, 12) 'V 2
arr(a, 13) = 1 'V 2
arr(a + 1, 13) = 1 'V 2
a2 = a2 + 1 'aktive Entries
End If
Next a
#If Test = 1 Then
Worksheets("Tabelle4").Range("AC1:AO" & LoLetzte) = arr 'Test 3 'V 2
#End If

'=============================================================================== =
'Sortieren Array nach aktiv,Nr, Buchstabe, Datei, Differenz, Wert
'=============================================================================== =
Call BubbleSort(arr, UBound(arr), 3, 1) 'Wert
Call BubbleSort(arr, UBound(arr), 12, 1) 'Differenz 'V 2
Call BubbleSort(arr, UBound(arr), 11, 1) 'Datei 'V 2
Call BubbleSort(arr, UBound(arr), 1, 1) 'Buchstabe
Call BubbleSort(arr, UBound(arr), 2, 1) 'Nr
Call BubbleSort(arr, UBound(arr), 13, 0) 'akiv 'V 2
#If Test = 1 Then
Worksheets("Tabelle4").Range("AQ1:BC" & LoLetzte) = arr 'Test 4 'V 2
#End If

'=============================================================================== =
'Aufbau arr2
'=============================================================================== =
ReDim arr2(1 To LoLetzte, 10) 'V 2
a2 = 0
a = 1
zNr = ""
Do While a <= LoLetzte
If arr(a, 13) = 0 Then Exit Do 'Keine weiteren relevante Einträge 'V 2
If arr(a, 2) <> zNr Then
zNr = arr(a, 2)
For r = 0 To 1
a2 = a2 + 1
For i = 1 To 10 'Felder A - J V 2
arr2(a2, i) = arr(a + r, i) 'V 2
Next i 'V 2
Next r
a = a + 2
Else
a = a + 1
End If
Loop
#If Test = 1 Then
Worksheets("Tabelle4").Range("BE1:BQ" & LoLetzte) = arr 'Test 5 'V 2
#End If

'=============================================================================== =
'Anzeige Ergebnsi
'=============================================================================== =
Worksheets("Tabelle3").Range("A1:J" & UBound(arr2)) = arr2 'V 2
End Sub


Function BubbleSort(arr, idx_Ubound As Long, SortIndex As Long, swA As Integer)
'***********************************************************
' Sortieren 2-dimensionales Array
'***********************************************************
' arr = zu sortierendes array
' idx_Ubound = Obergrenze des zu sortierenden Array-Teils
' SortIndex = Position Sortierfeld
' swA = Sortierreihenfolge (0 = absteigend, 1 = aufsteigend)

Dim blnNoSwaps As Boolean
Dim lngItem As Long
Dim vntTemp() As Variant
Dim lngCol As Long
ReDim vntTemp(1 To UBound(arr, 2))
Do
blnNoSwaps = True
For lngItem = LBound(arr) To idx_Ubound - 1
If (swA = 1 And arr(lngItem, SortIndex) > arr(lngItem + 1, SortIndex)) Or _
(swA = 0 And arr(lngItem, SortIndex) < arr(lngItem + 1, SortIndex)) Then
blnNoSwaps = False
For lngCol = 1 To UBound(arr, 2) 'V 2
vntTemp(lngCol) = arr(lngItem, lngCol)
arr(lngItem, lngCol) = arr(lngItem + 1, lngCol)
arr(lngItem + 1, lngCol) = vntTemp(lngCol)
Next
End If
Next
Loop While Not blnNoSwaps
End Function

AlexF.
22.01.2014, 14:26
Also der obige Code funktioniert bei 5 von 6 Dokumtenten,

allerdings habe ich ein Dokument, da funktioniert er nicht, beziehungsweise sind in diesem Dokument doch doppelte Werte in Spalte A & B gleichzeitig!!!

In deinem Code ist ja schon drinnen, dass wenn welche doppelt sind, eine Fehlermeldung kommt!

Könntest du mir vll noch ein letztes mal zu diesem Thema helfen :)

Wenn doppelter Wert auftaucht, dann soll nicht wie gehabt sofort die Fehlermeldung kommen, sonder es soll das gewählt werden, dass in Spalte J KEIN "-" hat.

Ist das geprüft und die Auswahl auch darüber nicht möglich, dann soll wie gehabt die Fehlermeldung kommen!

Hoffe ich habe das verständlich geschrieben :)

Habe mich an einem Extra Code versucht, den ich laufen lassen wollte aber gescheitert! Ausserdem ist die Lösung eher suboptimal, da ich die mti "-" dann einfach gelöscht hätte und dann wäre keine Fehlermeldung mehr gekommen. Mir wär aber lieber wenn die in dem Dokument drinnen beliben und einfach nicht gewählt werden: Hier mein Versuch, der nicht dem gewünschten enspricht :(

Sub Verbinden()
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
For Zeile = 1 To Cells(Rows.Count, 2).End(xlUp).Row
If Cells(Zeile, 2) > "" Then
Cells(Zeile, 2).Select
ActiveCell.FormulaR1C1 = Cells(Zeile, 2)
Cells(Zeile, 3).Select
ActiveCell.FormulaR1C1 = Cells(Zeile, 3)
Cells(Zeile, 1) = "=RC[1]&RC[2]"
End If
Next Zeile
End Sub

Sub DoppelteBezeichnungLöschen1()
Dim Zeile As Integer
For Zeile = 1 To Cells(Rows.Count, 1).End(xlUp).Row
For x = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(Zeile, 1).Value = Cells(x, 1).Value Then
If Cells(Zeile, 10) = "-" Then
Cells(Zeile, 1).Select
Selection.EntireRow.Delete
End If
End If
x = x + 1
Next x
Next Zeile
End Sub

aloys78
22.01.2014, 22:08
Hallo Alex,
Also der obige Code funktioniert bei 5 von 6 Dokumtenten,
allerdings habe ich ein Dokument, da funktioniert er nicht, beziehungsweise sind in diesem Dokument doch doppelte Werte in Spalte A & B gleichzeitig!!!
Das sind die Doppel, die angeblich nicht vorkommen - offenbar wieder einmal der Unterschied zwischen Theorie und Praxis.

Nachstehend der Gesamt-Code, der die Doppel nach deinen Vorgaben "verkraftet", zumindest mit meinen Testdaten.

Gruß
Aloys

Option Explicit
Option Base 1

'Version 3 vom 22.01.2014

Sub Vergleichen()
Dim LoLetzte1 As Long 'Letzte belegte Zeile in Tabelle1 1
Dim LoLetzte2 As Long 'Letzte belegte Zeile in Tabelle1 2
Dim LoLetzte As Long
Dim arr() 'Array zum Sammeln der Daten
Dim arr2() 'Array für Ergebnsi
Dim a As Long 'Index für Array arr
Dim a2 As Long 'Index für Array arr2
Dim ws As Worksheet
Dim ws1 As Worksheet 'Worksheet Tabelle 1
Dim ws2 As Worksheet 'Worksheet Tabelle 2
Dim r As Long 'Zeilen#
Dim i As Integer 'Schleifenzähler 'V2
Dim w As Long 'Nr Worksheet
Dim zNr 'Vergleichsfeld für die Nummer
Dim spJ1 As Long 'Sp J Position n: 0 = kein Minus, 1 = Minus enthalten
Dim spJ2 As Long 'Sp J Position n+1: 0 = kein Minus, 1 = Minus enthalten

'=============================================================================
'Initialisieren
'=============================================================================
Set ws1 = Worksheets("Tabelle1")
Set ws2 = Worksheets("Tabelle2")
LoLetzte1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
LoLetzte2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
ReDim arr(1 To LoLetzte1 + LoLetzte2, 1 To 13) 'V 2
'Merkmal 1, Merkmal 2 (Zahl), Menge, Sp d - J, Datei, Differenz, Auswahlzeichen 'V 2

'==============================================================================
'Laden Array
'==============================================================================
a = 0
For w = 1 To 2
If w = 1 Then
Set ws = ws1
LoLetzte = LoLetzte1
Else
Set ws = ws2
LoLetzte = LoLetzte2
End If
For r = 1 To LoLetzte
a = a + 1
arr(a, 11) = w 'Datei 1 oder 2 'V 2
With ws
arr(a, 1) = .Range("A" & r) 'Merkmal 1 - Buchstabe
arr(a, 2) = .Range("B" & r) 'Merkmal 2 - Zahl
arr(a, 3) = .Range("C" & r) 'Menge
For i = 4 To 10 'Spaltenwerte D - J 'V 2
arr(a, i) = .Cells(r, i) 'V 2
Next i 'V 2
arr(a, 12) = 0 'Grundstellung Differenz 'V 2
arr(a, 13) = 0 'Grundstellung Auswahlzeichen 'V 2
End With
Next r
Next w
LoLetzte = LoLetzte1 + LoLetzte2
#If Test = 1 Then 'Parameter wird unter 'Eigenschaften von VBA-Projekt' definiert
Worksheets("Tabelle4").Range("A:BQ").ClearContents 'V 2
Worksheets("Tabelle4").Range("A1:M" & LoLetzte) = arr 'Test 1 'V 2
#End If

'==============================================================================
'Sortieren Array nach Zahl, Buchstabe, Datei
'==============================================================================
Call BubbleSort(arr, UBound(arr), 11, 1) 'V 2
Call BubbleSort(arr, UBound(arr), 1, 1)
Call BubbleSort(arr, UBound(arr), 2, 1)
#If Test = 1 Then
Worksheets("Tabelle4").Range("O1:AA" & LoLetzte) = arr 'Test 2 'V 2
#End If

'===============================================================================
'Vergleichen
'===============================================================================
a2 = 0
For a = 1 To UBound(arr) - 1
If arr(a, 2) = arr(a + 1, 2) And arr(a, 1) = arr(a + 1, 1) Then 'Gruppenbegriffe Pos n und n+1 sind gleich
If arr(a, 11) = arr(a + 1, 11) Then 'Pos n und n+1 gehören zur gleichen Quell-Datei 'V 2
spJ1 = InStr(1, arr(a, 10), "-") 'V 3
spJ2 = InStr(1, arr(a + 1, 10), "-") 'V 3
If spJ1 = spJ2 Then 'die Position enthalten entweder beide "-" bzw kein "-" 'V 3
MsgBox "In Tabelle " & arr(a, 11) & " ist " & arr(a, 1) & " " & arr(a, 2) & " doppelt !", vbCritical 'V 3
Exit Sub
ElseIf spJ1 = 0 Then 'Position 1 enthält kein "-", aber Position 2 'V 3
arr(a, 13) = 1 'V 3
arr(a + 1, 13) = 0 'V 3
Else 'Position 2 enthält kein "-", aber Position 1 'V 3
arr(a, 13) = 0 'V 3
arr(a + 1, 13) = 1 'V 3
End If 'V 3
Else 'V 3
arr(a, 12) = Abs(arr(a, 3) - arr(a + 1, 3)) 'Differenz 'V 2
arr(a + 1, 12) = arr(a, 12) 'V 2
a2 = a2 + 1 'aktive Entries
arr(a, 13) = 1 'V 3
arr(a + 1, 13) = 1 'V 3
End If
End If
Next a
#If Test = 1 Then
Worksheets("Tabelle4").Range("AC1:AO" & LoLetzte) = arr 'Test 3 'V 2
#End If

'=============================================================================== =
'Sortieren Array nach aktiv,Nr, Buchstabe, Datei, Differenz, Wert
'=============================================================================== =
Call BubbleSort(arr, UBound(arr), 3, 1) 'Wert
Call BubbleSort(arr, UBound(arr), 12, 1) 'Differenz 'V 2
Call BubbleSort(arr, UBound(arr), 11, 1) 'Datei 'V 2
Call BubbleSort(arr, UBound(arr), 1, 1) 'Buchstabe
Call BubbleSort(arr, UBound(arr), 2, 1) 'Nr
Call BubbleSort(arr, UBound(arr), 13, 0) 'akiv 'V 2
#If Test = 1 Then
Worksheets("Tabelle4").Range("AQ1:BC" & LoLetzte) = arr 'Test 4 'V 2
#End If

'=============================================================================== =
'Aufbau arr2
'=============================================================================== =
ReDim arr2(1 To LoLetzte, 10) 'V 2
a2 = 0
a = 1
zNr = ""
Do While a <= LoLetzte
If arr(a, 13) = 0 Then Exit Do 'Keine weiteren relevante Einträge 'V 2
If arr(a, 2) <> zNr Then
zNr = arr(a, 2)
For r = 0 To 1
a2 = a2 + 1
For i = 1 To 10 'Felder A - J V 2
arr2(a2, i) = arr(a + r, i) 'V 2
Next i 'V 2
Next r
a = a + 2
Else
a = a + 1
End If
Loop
#If Test = 1 Then
Worksheets("Tabelle4").Range("BE1:BQ" & LoLetzte) = arr 'Test 5 'V 2
#End If

'=============================================================================== =
'Anzeige Ergebnsi
'=============================================================================== =
Worksheets("Tabelle3").Range("A1:J" & UBound(arr2)) = arr2 'V 2
End Sub


Function BubbleSort(arr, idx_Ubound As Long, SortIndex As Long, swA As Integer)
'***********************************************************
' Sortieren 2-dimensionales Array
'***********************************************************
' arr = zu sortierendes array
' idx_Ubound = Obergrenze des zu sortierenden Array-Teils
' SortIndex = Position Sortierfeld
' swA = Sortierreihenfolge (0 = absteigend, 1 = aufsteigend)

Dim blnNoSwaps As Boolean
Dim lngItem As Long
Dim vntTemp() As Variant
Dim lngCol As Long
ReDim vntTemp(1 To UBound(arr, 2))
Do
blnNoSwaps = True
For lngItem = LBound(arr) To idx_Ubound - 1
If (swA = 1 And arr(lngItem, SortIndex) > arr(lngItem + 1, SortIndex)) Or _
(swA = 0 And arr(lngItem, SortIndex) < arr(lngItem + 1, SortIndex)) Then
blnNoSwaps = False
For lngCol = 1 To UBound(arr, 2) 'V 2
vntTemp(lngCol) = arr(lngItem, lngCol)
arr(lngItem, lngCol) = arr(lngItem + 1, lngCol)
arr(lngItem + 1, lngCol) = vntTemp(lngCol)
Next
End If
Next
Loop While Not blnNoSwaps
End Function