|
Thema
|
Datum
|
Von Nutzer
|
Rating
|
Antwort
|
|
30.09.2016 11:10:09 |
Michael |
|
|
 Unterschiede aus 2 Tabellen in andere Tabelle kopieren |
30.09.2016 11:22:32 |
Michael |
|
|
|
30.09.2016 11:46:15 |
Gast91081 |
|
|
Von:
Michael |
Datum:
30.09.2016 11:22:32 |
Views:
834 |
Rating:
|
Antwort:
|
Thema:
Unterschiede aus 2 Tabellen in andere Tabelle kopieren |
|
Public Sub Auswertung()
Dim lastRow1 As Long
Dim lastRow2 As Long
Dim lastRow3 As Long
Dim lastRow4 As Long
Dim arr1 As Variant
Dim arr2 As Variant
Dim getCompare As Boolean
Dim r1 As Long
Dim r2 As Long
Dim r3 As Long
Dim r4 As Long
Dim lastcolo1 As Long
Dim lastcolo As Long
Dim blatt3 As Object
Dim blatt4 As Object
Dim blattname3 As String
Dim blattname4 As String
Dim nba3 As Boolean
Dim nba4 As Boolean
Dim r As Range
blattname3 = "Unveränderte Daten"
For Each blatt3 In Sheets
If blatt3.Name = blattname3 Then nba3 = True
Next blatt3
If nba3 = False Then
With ThisWorkbook
.Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "Unveränderte Daten"
End With
End If
blattname4 = "Neue u. veränderte Daten"
For Each blatt4 In Sheets
If blatt4.Name = blattname4 Then nba4 = True
Next blatt4
If nba4 = False Then
With ThisWorkbook
.Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "Neue u. veränderte Daten"
End With
End If
'***ScreenUpdating
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'***Einlesen
lastRow1 = Tabelle1.Range("O" & Rows.Count).End(xlUp).Row
lastRow2 = Tabelle2.Range("O" & Rows.Count).End(xlUp).Row
lastRow3 = Tabelle3.Range("O" & Rows.Count).End(xlUp).Row
lastRow4 = Tabelle4.Range("O" & Rows.Count).End(xlUp).Row
arr1 = Tabelle1.Range("A1").Resize(lastRow1, 20)
arr2 = Tabelle2.Range("A1").Resize(lastRow2, 20)
'***Tabelle3 und Tabelle4 aktualisieren
'***Zielbereiche löschen
Tabelle3.Range("A3").Resize(lastRow3, 20).EntireRow.Delete
Tabelle4.Range("A3").Resize(lastRow4, 20).EntireRow.Delete
'***Zielbereiche neu füllen
r3 = 2: r4 = 3
For r1 = 2 To lastRow1
getCompare = False
'***Übereinstimmungen in Tabelle3 eintragen
For r2 = 2 To lastRow2
If arr1(r1, 3) = arr2(r2, 3) And arr1(r1, 3) = arr2(r2, 3) Then
Tabelle1.Range("A" & r1).EntireRow.Copy Tabelle3.Cells(r3, "A")
Tabelle2.Cells(r2, "D").Copy Tabelle3.Cells(r3, "G")
r3 = r3 + 1: getCompare = True
Exit For
End If
Next r2
'***Abweichungen in Tabelle4 eintragen
If getCompare = False Then
Tabelle1.Range("A" & r1).EntireRow.Copy Tabelle4.Cells(r4, "A")
r4 = r4 + 1
End If
Next r1
'***ScreenUpdating
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
'***Erfolgsmeldung
MsgBox "Ich habe fertig"
End Sub
Das ist, was ich bis jetzt zusammen gebracht habe, aber so wirklich funktionieren tut es leider nicht :( |
- Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
- Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
- Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
- Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
- Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei
Antworten auf Ihren Beitrag zu benachrichtigen
Bitte geben Sie ein aussagekräftiges Thema an.
Bitte geben Sie eine gültige Email Adresse ein!
- Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
- Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
- Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
- Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
- Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei
Antworten auf Ihren Beitrag zu benachrichtigen
|
Thema
|
Datum
|
Von Nutzer
|
Rating
|
Antwort
|
|
30.09.2016 11:10:09 |
Michael |
|
|
Unterschiede aus 2 Tabellen in andere Tabelle kopieren |
30.09.2016 11:22:32 |
Michael |
|
|
|
30.09.2016 11:46:15 |
Gast91081 |
|
|