Änderungen unter Berücksicht. D:E übernehmen

Forumthread: Änderungen unter Berücksicht. D:E übernehmen

Wolfang

Hallo,
der untenstehende Code bewirkt wohl, dass aus einer Excel-Mappe (ist geschlossen) auf dem Desktop Daten gegenüber der aktuellen Mappe verglichen werden und Änderungen/Unterschiede in den Spalten I:K in die aktuelle Mappe überspielt werden. Wie kann der Code evtl. geändert werden, dass die Spalten D:E Berücksichtigung finden und eine Abhängigkeit hierzu besteht. Momentan kann passieren, dass zwei ähnliche Datensätze (Name, Vorname z.B. gleich) bestehen und die Änderungen in I:K somit falsch zugeordnet werden bzw. immer dann nur der erste Datensatz berücksichtigt wird. Spalte D enthält eine Kundennummer und Spalte E ein Datum. Die Kundennummer könnte dabei durchaus doppelt vorkommen, aber nicht mehr in der Kombination mit dem jeweiligen Datum. Danke schon jetzt für die Rückmeldungen.
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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

AW: Änderungen unter Berücksicht. D:E übernehmen

10.10.2009 13:42:03

fcs

Hallo Wolfgang,
dieser Code ist aus dem Zusammenhang herausgerissen.
Es fehlen:
- die Variablendeklarationen
- die Prozedur, die die Prozedur "Prüfen" aufruft
- die Function "Durchsuchen"
Zur Problem-Lösung muss die Function "Durchsuchen" angepasst werden, so dass außer der Kunden-Nummer in der Schlüsselspalte auch noch das Datum auf Übereinstimmung geprüft wird. Für das 2. Kriterium (Vergleichsdatum) müssen zusätzliche Variablen für Wert und SpaltenNummer definiert werden deren Werte der Durchsuchen-Function übergeben werden müssen.
Gruß
Franz

AW: Änderungen unter Berücksicht. D:E übernehmen

10.10.2009 14:30:16

Wolfgang

Hallo Franz,
herzlichen Dank für Deine Rückmeldung und Deine Hinweise; Wenn ich mich recht entsinne, hattest Du mir seinerzeit auch die Codes zur Verfügung gestellt. - Ich hoffe, dass ich Deine Hinweise richtig verstanden habe und die richtigen "Komponenten" kopiert habe. Danke schon jetzt wieder für Deine Rückmeldung.
Gruß - Wolfgang
Option Explicit
'dieser Part dient ausschließlich dem Datenableich und dem Import der Änderungen
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 = 2 '1.Datenzeile in Blatt Altdaten
Private Const Zeile1Grund = 2 '1.Datenzeile in Blatt Grunddaten
Private Const Zeile1Gesamt = 1 '1.Datenzeile in Blatt Gesamt
'dient für den Import von Tabellenblättern aus Mappen a.d.
Public meAreaTabellen
Public Desktop As String
Public objDatei As Object

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

Sub Alt_Grunddaten_aktualiseren()
Application.ScreenUpdating = False
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
Application.ScreenUpdating = True
End Sub

AW: Änderungen unter Berücksicht. D:E übernehmen

10.10.2009 21:55:36

fcs

Hallo Wolfgang,
hier die angepassten Prozeduren -jedoch ungetestte.
Die Function "Durchsuchen" ist komplett geändert.
In den anderen Prozeduren und Deklarationen hab ich geänderten/neuen Zeilen markiert.
Gruß
Franz

Option Explicit
'dieser Part dient ausschließlich dem Datenableich und dem Import der Änderungen
Private wksGesamt As Worksheet, wksAlt As Worksheet, wksGrund As Worksheet
Private lngZeile As Long, lngZeileZiel As Long
Private varSuchen, rngGefunden As Range, varKriterium2                '##geändert
Private lngSpalte As Long, bolGeaendert As Boolean
Private Const SpalteSchluessel = 4 'Spalte D - Spalte mit eindeutgem Schlüsselfeld
Private Const SpalteKriterium2 = 5 'Spalte E - Spalte mit 2. Kriterium '##neu
Private Const Zeile1Alt = 2 '1.Datenzeile in Blatt Altdaten
Private Const Zeile1Grund = 2 '1.Datenzeile in Blatt Grunddaten
Private Const Zeile1Gesamt = 1 '1.Datenzeile in Blatt Gesamt
'dient für den Import von Tabellenblättern aus Mappen a.d.
Public meAreaTabellen
Public Desktop As String
Public objDatei As Object
Private Function Durchsuchen(varSuche, varSuche2, wksSuche As Worksheet, _
ByVal lngSpalte As Long, ByVal lngSpalte2 As Long, _
Optional ByVal lngZeile1 As Long = 1) As Range
'Suche in Spalte eines Tabellenblatts mit zusätlichem Kriterium und _
Rückgabe der gefundenen Zelle                 'Function komplett überarbeitet
Dim rngSuche As Range, strAdresse1 As String
With wksSuche
'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
'Hauptkriterium suchen
Set Durchsuchen = rngSuche.Find(what:=varSuche, LookIn:=xlValues, lookat:=xlWhole)
If Not Durchsuchen Is Nothing Then
'Zelladresse der 1. Fundstelle merken
strAdresse1 = Durchsuchen.Address
Do
'2. Kriterium prüfen
If wksSuche.Cells(Durchsuchen.Row, lngSpalte2).Value = varSuche2 Then
Exit Do
End If
'Suche wiederholen
Set Durchsuchen = rngSuche.FindNext(after:=Durchsuchen)
If Durchsuchen.Address = strAdresse1 Then
'Übereinstimmung für beide Kriterien wurde nicht gefunden
Set Durchsuchen = Nothing
Exit Do
End If
Loop
End If
End With
End Function
Sub Alt_Grunddaten_aktualiseren()
Application.ScreenUpdating = False
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)
varKriterium2 = .Cells(lngZeile, SpalteKriterium2)           '##neu
'Blatt Altdaten aktualisieren
Call Pruefen(wksZiel:=wksAlt, Zeile1:=Zeile1Alt)
'Blatt Grunddaten aktualisieren
Call Pruefen(wksZiel:=wksGrund, Zeile1:=Zeile1Grund)
Next
End With
Application.ScreenUpdating = True
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, varSuche2:=varKriterium2, _
wksSuche:=wksZiel, lngZeile1:=Zeile1, lngSpalte:=SpalteSchluessel, _
lngSpalte2:=SpalteKriterium2)                               '##geändert
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

Danke Franz, läuft einwandfrei

11.10.2009 07:22:27

Wolfgang

Hallo Franz,
erneut recht herzlichen Dank für Deine Rückmeldung und Deine Ausarbeitungen sowie auch Deine Geduld mit mir. - Danke auch dafür, dass Du die Änderungen beschrieben hast. Die Codes laufen einwandfrei und "überspielen" nun auch die Daten von mehreren Datensätzen. Ein schönes Wochenende.
Herzliche Grüße
Wolfgang

Beliebteste Forumthreads (12 Monate)

Änderungen unter Berücksicht. D:E übernehmen

Forumthread: Änderungen unter Berücksicht. D:E übernehmen

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Änderungen unter Berücksicht. D:E übernehmen

Forumthread: Änderungen unter Berücksicht. D:E übernehmen

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread