Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1028to1032
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Änderungen in Tabellen via VBA vornehmen

Änderungen in Tabellen via VBA vornehmen
06.12.2008 15:50:24
Wolfgang
Hallo,
in einer Mappe befinden sich 3 Tabellenblätter; Gesamt, Grunddaten und Altdaten - In Gesamt werden unterschiedlich viele Daten, die aber alle immer das Format zu Tabelle Grund- und Altdaten haben, eingespielt. Im beiliegenden Code, wenn ich ihn richtig interpretiere, werden Veränderungen zwischen dem einen und dem anderen Tabellenblatt automatisch übertragen. Wie müßte der Code, der am liebsten über Schaltfläche funktionieren sollte, abgeändert werden, damit ein Abgleich von "Gesamt" zu Altdaten und Grunddaten erfolgen kann. - Also, alle Veränderungen/Eintragungen in Spalte I:K von "Gesamt" sollten zu Alt- und Grunddaten übertragen werden (dabei allerdings immer auch zum richtigen Schlüssel bzw. in die richtige Zeile). Schlüssel ist die Spalte D (Kundennummer und somit einmalig). - Danke schon jetzt wieder für die Rückmeldungen.
Herzliche Grüße
Wolfgang
Hier der I. Code aus dem Beispiel (hinter Worksheets "Tab1")

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim wks1 As Worksheet, wks2 As Worksheet, Finden As Range
Dim SpS1 As Long, SpS2 As Long, Sp As Long
Set wks1 = ThisWorkbook.Sheets("Tab1")
Set wks2 = ThisWorkbook.Sheets("Tab2")
SpS1 = 1 'Spalte mit Schlüsselsfeldern in Blatt 1
SpS2 = 1 'Spalte mit Schlüsselsfeldern in Blatt 2
If Target.Column = 2 Then 'Spalte in Blatt 1
Sp = 2 'ensprechende Spalte in Blatt 2
Set Finden = wks2.Columns.Find(What:=wks1.Cells(Target.Row, SpS1), LookIn:=xlValues, Lookat: _
=xlWhole)
If Finden Is Nothing Then
If MsgBox("Schlüssel in Tabelle " & wks2.Name & " nicht vorhanden." & vbLf & vbLf _
& "Zeile in" & wks2.Name & " einfügen?", vbYesNo, "Tabellenabgleich") = vbYes Then
Call ZeilenDatenuebertragen1(wks1, wks2, Target.Row, SpS2)
End If
Else
If wks2.Cells(Finden.Row, Sp).Value  Target.Value Then
wks2.Cells(Finden.Row, Sp).Value = Target.Value
End If
End If
End If
If Target.Column = 3 Then 'Spalte in Blatt 1
Sp = 4 'ensprechende Spalte in Blatt 2
Set Finden = wks2.Columns.Find(What:=wks1.Cells(Target.Row, SpS1), LookIn:=xlValues, Lookat: _
=xlWhole)
If Finden Is Nothing Then
If MsgBox("Schlüssel in Tabelle " & wks2.Name & " nicht vorhanden." & vbLf & vbLf _
& "Zeile in" & wks2.Name & " einfügen?", vbYesNo, "Tabellenabgleich") = vbYes Then
Call ZeilenDatenuebertragen1(wks1, wks2, Target.Row, SpS2)
End If
Else
If wks2.Cells(Finden.Row, Sp).Value  Target.Value Then
wks2.Cells(Finden.Row, Sp).Value = Target.Value
End If
End If
End If
End Sub


Sub ZeilenDatenuebertragen1(Blatt1 As Worksheet, Blatt2 As Worksheet, Zeile1 As Long, SpS2 As Long)
' Fügt Daten einer Zeile aus Blatt1 in Blatt2 am Ende ein
Dim Zeile2 As Long
Zeile2 = Blatt2.Cells(65000, SpS2).End(xlUp).Row + 1 'nächste leere Zeile in Blatt 2
Blatt2.Cells(Zeile2, 1).Value = Blatt1.Cells(Zeile1, 1).Value
Blatt2.Cells(Zeile2, 2).Value = Blatt1.Cells(Zeile1, 2).Value
Blatt2.Cells(Zeile2, 4).Value = Blatt1.Cells(Zeile1, 3).Value
End Sub


Und hier der Code aus Tab2


Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim wks1 As Worksheet, wks2 As Worksheet, Finden As Range
Dim SpS1 As Long, SpS2 As Long, Sp As Long
Set wks1 = ThisWorkbook.Sheets("Tab1")
Set wks2 = ThisWorkbook.Sheets("Tab2")
SpS1 = 1 'Spalte mit Schlüsselsfeldern in Blatt 1
SpS2 = 1 'Spalte mit Schlüsselsfeldern in Blatt 2
If Target.Column = 2 Then 'Spalte in Blatt 2
Sp = 2 'ensprechende Spalte in Blatt 1
Set Finden = wks1.Columns.Find(What:=wks2.Cells(Target.Row, SpS2), LookIn:=xlValues, Lookat: _
=xlWhole)
If Finden Is Nothing Then
If MsgBox("Schlüssel in Tabelle " & wks1.Name & " nicht vorhanden." & vbLf & vbLf _
& "Zeile in" & wks1.Name & " einfügen?", vbYesNo, "Tabellenabgleich") = vbYes Then
Call ZeilenDatenuebertragen2(wks1, wks2, Target.Row, SpS1)
End If
Else
If wks1.Cells(Finden.Row, Sp).Value  Target.Value Then
wks1.Cells(Finden.Row, Sp).Value = Target.Value
End If
End If
End If
If Target.Column = 4 Then 'Spalte in Blatt 2
Sp = 3 'ensprechende Spalte in Blatt 1
Set Finden = wks1.Columns.Find(What:=wks2.Cells(Target.Row, SpS2), LookIn:=xlValues, Lookat: _
=xlWhole)
If Finden Is Nothing Then
If MsgBox("Schlüssel in Tabelle " & wks1.Name & " nicht vorhanden." & vbLf & vbLf _
& "Zeile in" & wks1.Name & " einfügen?", vbYesNo, "Tabellenabgleich") = vbYes Then
Call ZeilenDatenuebertragen2(wks1, wks2, Target.Row, SpS1)
End If
Else
If wks1.Cells(Finden.Row, Sp).Value  Target.Value Then
wks1.Cells(Finden.Row, Sp).Value = Target.Value
End If
End If
End If
End Sub


Sub ZeilenDatenuebertragen2(Blatt1 As Worksheet, Blatt2 As Worksheet, Zeile2 As Long, SpS1 As Long)
' Fügt Daten einer Zeile aus Blatt2 in Blatt1 am Ende ein
Dim Zeile1 As Long
Zeile1 = Blatt1.Cells(65000, SpS1).End(xlUp).Row + 1 'nächste leere Zeile in Blatt 2
Blatt1.Cells(Zeile1, 1).Value = Blatt2.Cells(Zeile2, 1).Value
Blatt1.Cells(Zeile1, 2).Value = Blatt2.Cells(Zeile2, 2).Value
Blatt1.Cells(Zeile1, 3).Value = Blatt2.Cells(Zeile2, 4).Value
End Sub


6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Änderungen in Tabellen via VBA vornehmen
08.12.2008 13:19:00
fcs
Hallo Wolfgang,
Die nachfolgenden Prozeduren führen auf Anforderung eine Aktualisierung der Daten in den Blättern Alt- und Grunddaten durch.
Die Namen der Blätter und Werte der Konstanten für die 1. Zeile mit Daten muss du anpassen.
Gruß
Franz

Option Explicit
Private wksGesamt As Worksheet, wksAlt As Worksheet, wksGrund As Worksheet
Private lngZeile As Long, lngZeileZiel As Long
Private varSuchen, rngGefunden As Range
Private lngSpalte As Long, bolGeaendert As Boolean
Private Const SpalteSchluessel = 4 'Spalte D - Spalte mit eindeutgem Schlüsselfeld
Private Const Zeile1Alt = 3     '1.Datenzeile in Blatt Altdaten
Private Const Zeile1Grund = 3   '1.Datenzeile in Blatt Grunddaten
Private Const Zeile1Gesamt = 3  '1.Datenzeile in Blatt Gesamt
Sub Alt_Grunddaten_aktualiseren()
Set wksGesamt = Worksheets("Gesamt")
Set wksAlt = Worksheets("Altdaten")
Set wksGrund = Worksheets("Grunddaten")
With wksGesamt
For lngZeile = Zeile1Gesamt To .Cells(.Rows.Count, SpalteSchluessel).End(xlUp).Row
varSuchen = .Cells(lngZeile, SpalteSchluessel)
'Baltt Altdaten aktualisieren
Call Pruefen(wksZiel:=wksAlt, Zeile1:=Zeile1Alt)
'Baltt Grunddaten aktualisieren
Call Pruefen(wksZiel:=wksGrund, Zeile1:=Zeile1Grund)
Next
End With
End Sub
Private Sub Pruefen(wksZiel As Worksheet, ByVal Zeile1 As Long)
'im Zielblatt Schluessel suchen und Daten vergleichen/aktualiseren
Set rngGefunden = Durchsuchen(varSuche:=varSuchen, wksSuche:=wksZiel, _
lngZeile1:=Zeile1, lngSpalte:=SpalteSchluessel)
With wksZiel
bolGeaendert = False
If rngGefunden Is Nothing Then
'Schlüssel in Blatt Gesamt ist im Zielblatt nicht vorhanden
'NeuenDatensatz anlegen
wksGesamt.Rows(lngZeile).Copy
'Nächste frei Zeile in Schluesselspalte
lngZeileZiel = .Cells(.Rows.Count, SpalteSchluessel).End(xlUp).Row + 1
'Formate kopieren
'       .Cells(lngZeileZiel, 1).PasteSpecial Paste:=xlFormats
'Werte kopieren
.Cells(lngZeileZiel, 1).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
bolGeaendert = True
Else
lngZeileZiel = rngGefunden.Row
'Spalten auf Änderungen prüfen
For lngSpalte = 1 To 11
Select Case lngSpalte
Case 9, 10, 11 'Spalten I , J und  K
If wksGesamt.Cells(lngZeile, lngSpalte).Value  _
.Cells(lngZeileZiel, lngSpalte).Value Then
.Cells(lngZeileZiel, lngSpalte).Value = _
wksGesamt.Cells(lngZeile, lngSpalte).Value
bolGeaendert = True
End If
Case Else
'do nothing
End Select
Next
End If
If bolGeaendert = True Then
'Änderungsdatum in Spalte L eintragen
.Cells(lngZeileZiel, 12).Value = Now
End If
End With
End Sub
Private Function Durchsuchen(varSuche, wksSuche As Worksheet, _
Optional ByVal lngZeile1 As Long = 1, _
Optional ByVal lngSpalte As Long = 0) As Range
'Suche in Spalte(n) eines Tabellenblatts und Rückgabe der gefundenen Zelle
Dim rngSuche As Range
With wksSuche
If lngSpalte = 0 Then
'in allen Spalten ab Zeile1 suchen
Set rngSuche = .Range(.Cells(lngZeile1, 1), .Cells.SpecialCells(xlCellTypeLastCell))
Else
'nur in Spalte suchen ab Zeile1
If .Cells(.Rows.Count, lngSpalte).End(xlUp).Row >= lngZeile1 Then
Set rngSuche = .Range(.Cells(lngZeile1, lngSpalte), _
.Cells(.Cells(.Rows.Count, lngSpalte).End(xlUp).Row, lngSpalte))
Else
'Keine Daten ab Zeile1 abwärts vorhanden
Set Durchsuchen = Nothing
Exit Function
End If
End If
Set Durchsuchen = rngSuche.Find(what:=varSuche, LookIn:=xlValues, lookat:=xlWhole)
End With
End Function


Anzeige
eine Frage noch.
08.12.2008 18:19:00
Wolfgang
Hallo Franz,
zunächst erneut wieder recht herzlichen Dank für Deine Rückmeldung und wiederum immense Ausarbeitungen, die ich niemals auch nur im Ansatz hinbekommen hätte. Ich hatte schon verschiedene Versionen und Möglichkeiten getestet, aber ohne Erfolg. Umsomehr freue ich mich riesig über Deine Rückmeldung. Der Code läuft auch grundsätzlich soweit . Wie lässt sich allerdings ausschalten, dass, wenn ich z.B. nur Daten aus "Grunddaten" gefiltert hatte und der Code dann auch in Grunddaten die Ergänzungen wunderbar einspielt, er allerdings dann die Datensätze in Altdaten noch hinten 'dranhängt. Mir fehlt im Code der Blick dafür, wo ich das evtl. verändern könnte. Wenn ich das richtig beobachte, würde der Code augenscheinlich Änderungen aus der Tabelle "Altdaten" gar nicht berücksichtigen. Die Kundennummer, also der Schlüssel könnte sowohl in Grunddaten, als auch in Altdaten vorkommen (seltener in beiden) - immer aus Richtung "Gesamt". Danke schon jetzt wieder für die Rückmeldung.
Herzliche Grüße
Wolfgang
Anzeige
AW: eine Frage noch.
08.12.2008 18:57:00
Wolfgang
Hallo Franz,
kurz noch eine Rückmeldung; ich hatte wohl übersehen, die Zeilen noch anzupassen, so dass der Code augenscheinlich in Altdaten keine Veränderungen vornahm. Das hat sich erledigt, ich hatte wohl, sorry, Deinen Hinweis, die Zeilen noch jeweils anzupassen, übersehen. Nun stelle ich auch fest, dass ein wechselseitiges Kopieren der jeweiligen Datensätze in die "gegenüberliegende" Tabelle erfolgt, den Code würde ich gerne "abgestellt" haben und ausschließlich nur die Veränderungen in Spalten I:K anhand des Schlüssels, also Spalte D, vornehmen lassen wollen. Danke schon jetzt auch wieder für Deine Rückmeldung. Ich werde mich aber auch noch weiter mit dem Code befassen.
Herzliche Grüße
Wolfgang
Anzeige
so richtig?
09.12.2008 08:07:21
Wolfgang
Hallo Franz,
ich glaube, ich habe evtl. den Part gefunden, um das Kopieren abzustellen. Würdest Du Dir vielleicht die Änderungen kurz anschauen, um festzustellen, ob ich sonst noch etwas übersehen habe? - Vielleicht auch noch eine andere Frage: Primärschlüssel ist ja die Spalte D - ich habe nun festgestellt, dass die Kundennummer in Spalte D doch vereinzelt doppelt vorkommt. Wäre denkbar, noch als weiteren Schlüssel die Spalte F einzubauen, wenn ja, was oder wo müsste ich was verändern? - Danke Dir schon jetzt wieder für die Rückmeldung.
Herzliche Grüße
Wolfgang

Private Sub Pruefen(wksZiel As Worksheet, ByVal Zeile1 As Long)
'im Zielblatt Schluessel suchen und Daten vergleichen/aktualiseren
Set rngGefunden = Durchsuchen(varSuche:=varSuchen, wksSuche:=wksZiel, _
lngZeile1:=Zeile1, lngSpalte:=SpalteSchluessel)
With wksZiel
bolGeaendert = False
If rngGefunden Is Nothing Then
'Schlüssel in Blatt Gesamt ist im Zielblatt nicht vorhanden
'NeuenDatensatz anlegen
' wksGesamt.Rows(lngZeile).Copy
'Nächste frei Zeile in Schluesselspalte
' lngZeileZiel = .Cells(.Rows.Count, SpalteSchluessel).End(xlUp).Row + 1
'Formate kopieren
'       .Cells(lngZeileZiel, 1).PasteSpecial Paste:=xlFormats
'Werte kopieren
'.Cells(lngZeileZiel, 1).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
bolGeaendert = True
Else
lngZeileZiel = rngGefunden.Row
'Spalten auf Änderungen prüfen
For lngSpalte = 1 To 11
Select Case lngSpalte
Case 9, 10, 11 'Spalten I , J und  K
If wksGesamt.Cells(lngZeile, lngSpalte).Value  _
.Cells(lngZeileZiel, lngSpalte).Value Then
.Cells(lngZeileZiel, lngSpalte).Value = _
wksGesamt.Cells(lngZeile, lngSpalte).Value
bolGeaendert = True
End If
Case Else
'do nothing
End Select
Next
End If
'If bolGeaendert = True Then
'Änderungsdatum in Spalte L eintragen
'.Cells(lngZeileZiel, 12).Value = Now
' End If
End With
End Sub


Anzeige
AW: so richtig?
09.12.2008 10:46:00
fcs
Hallo Wolfgang,
die Stelle, um das kopieren von nicht gefundenen Schlüsseln in die Zieltabelle zu verhindern, hast du korrekt identifiziert.
Die zusätzliche Prüfung auf die Übereinstimmung in Spalte F macht die Suchprozedur etwas koplizierter, da in einer Schleife ggf. alle Fundstellen des 1. Schlüssels geprüft werden müssen.
Hier nochmals der gesamte Code, da in fast allen Prozeduren ergänzungen erforderlich sind.
Gruß
Franz

Option Explicit
Private wksGesamt As Worksheet, wksAlt As Worksheet, wksGrund As Worksheet
Private lngZeile As Long, lngZeileZiel As Long
Private varSuchen, varSuchen2, rngGefunden As Range
Private lngSpalte As Long, bolGeaendert As Boolean
Private Const SpalteSchluessel = 4 'Spalte D - Spalte mit eindeutgem oder 1. Schlüsselfeld
Private Const SpalteSchluessel2 = 6 'Spalte F - Spalte mit 2. Schlüsselfeld
Private Const Zeile1Alt = 3     '1.Datenzeile in Blatt Altdaten
Private Const Zeile1Grund = 3   '1.Datenzeile in Blatt Grunddaten
Private Const Zeile1Gesamt = 3  '1.Datenzeile in Blatt Gesamt
Sub Alt_Grunddaten_aktualiseren()
Set wksGesamt = Worksheets("Gesamt")
Set wksAlt = Worksheets("Altdaten")
Set wksGrund = Worksheets("Grunddaten")
With wksGesamt
For lngZeile = Zeile1Gesamt To .Cells(.Rows.Count, SpalteSchluessel).End(xlUp).Row
varSuchen = .Cells(lngZeile, SpalteSchluessel)
varSuchen2 = .Cells(lngZeile, SpalteSchluessel2)
'Blatt Altdaten aktualisieren
Call Pruefen(wksZiel:=wksAlt, Zeile1:=Zeile1Alt)
'Blatt Grunddaten aktualisieren
Call Pruefen(wksZiel:=wksGrund, Zeile1:=Zeile1Grund)
Next
End With
End Sub
Private Sub Pruefen(wksZiel As Worksheet, ByVal Zeile1 As Long)
'im Zielblatt Schluessel suchen und Daten vergleichen/aktualiseren
Set rngGefunden = Durchsuchen(varSuche:=varSuchen, wksSuche:=wksZiel, _
lngZeile1:=Zeile1, lngSpalte:=SpalteSchluessel, varSuche2:=varSuchen2, _
lngSpalte2:=SpalteSchluessel2)
With wksZiel
bolGeaendert = False
If rngGefunden Is Nothing Then
'Schlüssel in Blatt Gesamt ist im Zielblatt nicht vorhanden
'Do nothing, wenn Schlüssel nicht vorhanden, dann soll auch nicht aktualisiert werden
Else
lngZeileZiel = rngGefunden.Row
'Spalten auf Änderungen prüfen
For lngSpalte = 1 To 11
Select Case lngSpalte
Case 9, 10, 11 'Spalten I , J und  K
If wksGesamt.Cells(lngZeile, lngSpalte).Value  _
.Cells(lngZeileZiel, lngSpalte).Value Then
.Cells(lngZeileZiel, lngSpalte).Value = _
wksGesamt.Cells(lngZeile, lngSpalte).Value
bolGeaendert = True
End If
Case Else
'do nothing
End Select
Next
End If
If bolGeaendert = True Then
'Änderungsdatum in Spalte L eintragen
.Cells(lngZeileZiel, 12).Value = Now
End If
End With
End Sub
Private Function Durchsuchen(varSuche, wksSuche As Worksheet, _
Optional ByVal lngZeile1 As Long = 1, _
Optional ByVal lngSpalte As Long = 0, _
Optional ByVal varSuche2, _
Optional ByVal lngSpalte2 As Long = 0) As Range
'Suche in Spalte(n) eines Tabellenblatts und Rückgabe der gefundenen Zelle
'varSuche
'wksSuche
'lngZeile1 = Zeile ab der Wert in Spalte gesucht werden soll Standartwert = 0 = 1
'lngSpalte = Optionale Schlüsselspalte, Standartwert = 0, d.h. alle Zellen werden durchsucht
'lngSpalte2 = Optionale 2. Schlüsselspalte, Standartwert = 0, d.h. kein 2. Schlüssel
Dim rngSuche As Range, strAdresse1 As String
With wksSuche
If lngSpalte = 0 Then
'in allen Spalten ab Zeile1 suchen
Set rngSuche = .Range(.Cells(lngZeile1, 1), .Cells.SpecialCells(xlCellTypeLastCell))
Else
'nur in Spalte suchen ab Zeile1
If .Cells(.Rows.Count, lngSpalte).End(xlUp).Row >= lngZeile1 Then
Set rngSuche = .Range(.Cells(lngZeile1, lngSpalte), _
.Cells(.Cells(.Rows.Count, lngSpalte).End(xlUp).Row, lngSpalte))
Else
'Keine Daten ab Zeile1 abwärts vorhanden
Set Durchsuchen = Nothing
Exit Function
End If
End If
'Nach 1. Schlüssel suchen
Set Durchsuchen = rngSuche.Find(what:=varSuche, LookIn:=xlValues, lookat:=xlWhole)
If Not Durchsuchen Is Nothing Then
'2. Schlüsselspalte prüfen
If lngSpalte2 > 0 Then
If varSuche2  .Cells(Durchsuchen.Row, lngSpalte2) Then
strAdresse1 = Durchsuchen.Address 'Zell-Adresse der 1. Fundstelle merken
'Weitere Zellen mit 1. Schlüssel suchen
Do
Set Durchsuchen = rngSuche.FindNext(after:=Durchsuchen)
If Durchsuchen.Address = strAdresse1 Then
'Es wurde keine Übereinstimmung für den 2. Schlüssel gefunden
Set Durchsuchen = Nothing
Exit Do
Else
'Prüfen ob 2. Schlüssel für gefundene Zelle übereinstimmt
If varSuche2 = .Cells(Durchsuchen.Row, lngSpalte2) Then Exit Do
End If
Loop
End If
End If
End If
End With
End Function


Anzeige
Danke Franz - Super!!
09.12.2008 20:02:59
Wolfgang
Hallo Franz,
erneut recht herzlichen Dank für Deine Rückmeldungen und die weiteren Ausarbeitungen/Änderungen. Nicht nur Danke dafür, auch Danke für die jeweiligen Erläuterungen im Code. Ich weiß dann ungefähr wo ich im Code bin und was möglicherweise damit bewirkt wird. Ich freue mich sehr. Einfach nur super von Dir !
Der Code läuft einwandfrei und rund.
Herzliche Grüße
Wolfgang

307 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige