@Franz - habe eine Frage aus älterem Code
28.03.2014 12:29:01
Wolfgang
den nachfolgenden Code hattest Du mir vor etlichen Jahren zur Verfügung gestellt. Er bewirkt, dass zwischen der geöffneten Mappe und einer auf d. Desktop angewählten Mappe Änderungen/Unterschiede die in den Spalten I:K bestehen könnten, abgeglichen und ggfs. die Änderungen aus der "Desktopmappe" in die Spalten der geöffneten Mappe übertragen werden. Nun mußte ich in der Tabelle eine Spalte einfügen, so dass für die Abfrage nicht mehr die Spalten I:K, sondern die Spalten J:L maßgeblich sind. Ich hatte gehofft den Code lediglich an der Stelle abändern zu können und er läuft. Dem ist leider nicht so. Übersehe ich evtl. etwas? Die Spalten D:E für die Klärung des Hauptkriteriums bleiben dabei unverändert. - Danke Dir schon jetzt für eine Rückmeldung.
Herzliche Grüße - 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, 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
'Hier hatte ich gehofft, einfach die Spaltennummern zu verändern - klappt irgenwie aber leider _
_
nicht
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