HILFE!!! 2 Tabellen vergleichen und 3. erstellen

Hallo zusammen,
ich hoffe sehr ihr könnt mir helfen - vielleicht ist es ganz einfach und ich hab bloß mittlerweile von lauter Abgleichen und .... schon ein Brett vor'm Kopf.
Ich hab die Tabellen um die es geht als Datei angehängt.
https://www.herber.de/bbs/user/24896.xls
Was ist das Ziel:
Ich habe 2 Basistabellen und eine 3. Zieltabelle.
Nun sollen die Daten aus der 1. Tabelle (Spalte 1 ist der Such-Schlüssel, Spalte 2-5 sind die Daten zum Abgleich) mit den Daten aus der 2. Tabelle (Spalte 1 als Ergebnis-Schlüssel, Spalte 2 als Referenz für die Daten, Spalte 3 als Zielergebnis) abgeglichen werden.
Bei Übereinstimmung der 2 Suchkriterien soll nun dass 1. Suchkriterium in die 1. Spalte der Zieltabelle eingetragen werden und dass Zielergebnis in die 2. oder 3. oder 4. oder 5. Spalte.
Kriterium dafür in welche Spalte dass Zielergebnis eingetragen werden soll ist die Spalte aus der das Suchkriterium der 2. Spalte stammt.
Bitte bitte helft mir, ich mach solche Vergleiche jetzt schon seit 2 Tagen manuell - es konnte mir noch keiner weiterhelfen....
ich hab schon Albträume .~(
vielen Dank
mfg
Ana

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
Probier mal den Code.
Das Ergebnis wird ein einer Tabelle "Ergebnis" angezeigt.
Den Code kopieren
Deine Mappe öffnen
"Alt"+"F11" drücken
Rechte Maustaste auf "VBA-Projekt "DeinMappenname.xls"
Einfügen - Modul
Den Code dort reinkopieren
Die Tabellennamen in den Variablen bitte noch anpassen !!!
Extras - Makro - Makro ausführen - Code auswählen - Ausführen
Option Explicit

Sub Agg_Tables()
Dim Wks1 As Worksheet, Wks2 As Worksheet, tWks As Worksheet
Dim Wks1Lr As Integer, wks2Lr As Integer, tWksR As Integer
Dim Wks1SrcCol As Integer, Wks2SrcCol As Integer
Dim i As Integer, n As Integer, m As Integer
Dim srcRng As Range, srcRng2 As Range, tmpAddress As String
'*************************************
'Den Tabellennamen zwischen den Anführunszeichen bitte anpassen
'
'
'Tabelle "Objective;Activity;Goal"
Set Wks1 = Worksheets("Tabelle1")
'
'Tabelle "Objective;Activity A1;Activity A2;Activity B1;Activity B2"
Set Wks2 = Worksheets("Tabelle2")
'
'Suchbereiche definieren
'1 = Spalte A
'Wks1Daten
Wks1SrcCol = 1
'
'Wks2Daten
Wks2SrcCol = 1
'Ergebnistabelle erstellen
On Error Resume Next
'
'Tabelle "Objective;Goal 1;Goal 2;Goal 3;Goal 4"
Set tWks = Worksheets("Ergebnis")
'Ab hier nichts mehr verändern
'****************************************
'
'
If Err <> 0 Then
    Set tWks = Worksheets.Add
    tWks.Name = "Ergebnis"
    Err.Clear
End If
On Error GoTo 0
'Ergebnis löschen
With tWks
    .Cells.Clear
    .Cells(1, 1) = "Objective"
    .Cells(1, 2) = "Goal 1"
    .Cells(1, 3) = "Goal 2"
    .Cells(1, 4) = "Goal 3"
    .Cells(1, 5) = "Goal 4"
    .Range(.Cells(1, 1), .Cells(1, 5)).Font.Bold = True
End With
'Anzahl der Zellen definieren die zu prüfen sind
Wks1Lr = Wks1.Cells(Rows.Count, 1).End(xlUp).Row
'Beginn des Ergebnis Vergleichs in der Ergebnistabelle
tWksR = 1
'Prüfschleife starten
For i = 18 To Wks1Lr
    With Wks2
        Set srcRng = .Columns(Wks2SrcCol).Find(What:=Wks1.Cells(i, Wks1SrcCol), _
            LookAt:=xlWhole, LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlNext)
        If Not srcRng Is Nothing Then
            tmpAddress = srcRng.Address
            Do
                For n = 1 To 4
                    If srcRng.Offset(0, n) = Wks1.Cells(i, Wks1SrcCol).Offset(0, 1) Then
                        Set srcRng2 = tWks.Columns(1).Find(What:=srcRng, _
                            LookAt:=xlWhole, LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlNext)
                        If Not srcRng2 Is Nothing Then
                            If srcRng2.Offset(0, n) = "" Then
                                tWks.Cells(tWksR, 1) = Wks1.Cells(i, Wks1SrcCol)
                                tWks.Cells(tWksR, n + 1) = Wks1.Cells(i, Wks1SrcCol).Offset(0, 2)
                            Else
                                tWksR = tWksR + 1
                                tWks.Cells(tWksR, 1) = Wks1.Cells(i, Wks1SrcCol)
                                tWks.Cells(tWksR, n + 1) = Wks1.Cells(i, Wks1SrcCol).Offset(0, 2)
                            End If
                        Else
                            tWksR = tWksR + 1
                            tWks.Cells(tWksR, 1) = Wks1.Cells(i, Wks1SrcCol)
                            tWks.Cells(tWksR, n + 1) = Wks1.Cells(i, Wks1SrcCol).Offset(0, 2)
                        End If
                    End If
                Next n
                Set srcRng = .Columns(Wks2SrcCol).FindNext(after:=.Range(srcRng.Address))
                If srcRng.Address = tmpAddress Then Exit Do
            Loop
        End If
    End With
Next i
End Sub
Das Ergebnis sollte dann in etwa so aussehen

	A	B	C	D	E
1	Objective	Goal 1	Goal 2	Goal 3	Goal 4
2	EX1015	20
3	EX1015	203
4	EX1025	203	203
5	EX1035	243		243
6	EX2005	20
7	EX2005	121
8	EX2005	129		129
9	EX2010			20
10	EX2010	129		129	129
11	EX2015	73
12	EX2015	179		179
13	EX2020			73
14	EX2020			112
15	EX2020			121
16	EX2020			179
17	EX2020	300		300
18	EX2025	73
19	EX2025	112
20	EX2025	179

Viel Spass.
Das ganze dauert etwa 10 Sekunden.
Rückmeldung wäre schön.
Gruss Rainer

Beliebteste Forumthreads (12 Monate)

HILFE!!! 2 Tabellen vergleichen und 3. erstellen

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

305 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

HILFE!!! 2 Tabellen vergleichen und 3. erstellen

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

305 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread