AW: da gibt es leider noch "Ecken und Kanten" ...
05.06.2016 15:00:22
Piet
Hallo Werner,
ich habe gerade deinen Hinweis gelesen, und im Makro sind tatsächlich noch Fehler.
Wie ich selbst bemerkt habe funktioniert Replace nicht richtig, das wurde geändert.
Ich bitte dich und Steffi die neuen Makros zu testen. Es sollte der Lösung näher kommen.
Hallo Steffi,
kennst du Pipi Langstrumpf, und ihren persönlichen Ordnungssinn in der "Villa Kunterbunt" ?
So must du dir bei Piet die Entwicklungsphase eines Makros vorstellen. Man hat eine Idee, es klappt nicht alles
wie es soll, dann experimentiert man solange, bis es klappt. Das Chaos im Modulblatt sieht keiner ausser mir.
Dann bereinigt man es für Steffi, versieht es mit Kommentaren, das es andere auch verstehen, und oh jeee..
macht dumme kleine Flüchtigkeitsfehler. Den hast du dann sofort entdeckt!! Das Löschen des Bestandes.
Ich sende dir zum Austausch ein neues Makro für Modulblatt "Tabelle2_abgleichen". Schau dir bitte vorher einmal
die alte Makro Zeile an, nach dem Kommentar (grün): - 'Prüf-Spalte in Tabelle2 löschen
dort findest du den Befehl: - .Range(Adr & lz2).ClearContents - vergessen wurde Tab2 davor zu schreiben!!
Excel nimmt das persönlich, und bezog diesen Befehl dann auf With Worksheets("Tabelle1") Spalte J
Gelöscht werden sollte aber die Prüfspalte J in Tabelle2. Nur, der PC kann nicht denken, befolgt Befehle.
Dabei fiel mir auch auf das Replace in Zeile 13 nicht richtig funktioniert, in 113 austauschte.
Der Fehler wurde korrigiert, deswegen schicke ich dir das komplette gänderte Makro zum tauschen.
Neue Makros:
Modul3: - vorhandes Makro löschen, es existiert bereits in - Modulblatt Tabelle_prüfen
Dafür bitte das neue Makro für Lösch Routinen einfügen und selbst testen ob es okay ist.
Es sind drei Makro die du ins Modul3 kopieren musst. Jedes mit eigener Funktion.
Zwei Makros sind zum Löschen gedacht. Das erste sucht nach Zellen mit "#NV" und löscht sie.
Das dritte Makro ist nur ais zusäztliches Makro gedacht, sucht "No Find" Text und löscht sie.
Das erste Makro fast die Makros zusammen für den Button "T2 Abgleichen" - bei Klick.
Dann wird zuerst das löschen von "#NV" ausgeführt, danach der Tabellenabgleich mit Tabelle2.
Das dritte Makro ist zur Zeit deaktiviert, durch das "'" sieht der PC es als Kommentar an.
Wenn es benötigt wird brauchst du nur das Semikolon zu entfernen, dann laeuft es mit.
Ich hoffe wir kommen so einer guten Lösung näher. Würde mich sehr freuen,
Vielleicht erfüllt das neue Mkro auch die Anforderungen auf die Werner hinwies.
Dem Button "T2 Abgleichen" neues Makro zuweisen: - Formel_löschen_und_abgleichen
mfg Piet
PS Bitte sofort testen, in 2-3 Tagen fliege ich in Urlaub, bin einige Zeit weg.
Im Modulblatt "Tabelle2_abgleichen" bitte austauchen:
Option Explicit '4.6.2016 Piet für Herber Forum
'Korrektur: ** falsche Löschen Spalte F in Tabelle1 **
'Tab2 fehlte, dafür stand .Range (lösche Tabelle1)
'Replace Fehler: Formel neu erstellt über Tabelle2
Const PrüfSpaT2 = "F" 'Prüf-Spalte in Tabelle2 (doppelte)
Const PrüfSpaT1 = "J" 'Tabelle1 wird Prüfung mit ok markiert
Dim Tab2 As Object, AC As Object
Dim rFind As Object, Adr As String
Dim Artikel As String, lz1 As Long
Dim Lagerort As String, lz2 As Long
Dim pFind As Object, lZell As Long
'Makro vergleicht Tabelle2 mit Tabelle1
'neue Artikel werden mit Formel eingefügt
Sub Formel_mit_Tabelle2_abgleichen()
Dim d As Integer, u As Integer
Dim flg As String, msg As String
Set Tab2 = Worksheets("Tabelle2")
With Worksheets("Tabelle1")
'LastZell in Tabelle 1+2 ermittlen
lz1 = .Range("A3").End(xlDown).Row
lz2 = Tab2.Range("A2").End(xlDown).Row
'Prüf-Spalte in Tabelle1 löschen
Adr = PrüfSpaT1 & 1 & ":" & PrüfSpaT1
.Range(Adr & lz1).Clear 'Clr Schrift 7
'Prüf-Spalte mit "No Find" voladen
.Range(Adr & lz1 - 2).Offset(2, 0) = "No Find"
'Prüf-Spalte in Tabelle2 löschen
Adr = PrüfSpaT2 & 1 & ":" & PrüfSpaT2
Tab2.Range(Adr & lz2).ClearContents
'** Tab2 fehlte!! korrigiert 5.6.2016
'Schleife für Tabellen 1+2 vergleichen
For Each AC In Tab2.Range("A2:A" & lz2)
flg = Empty 'doppel Prüfung Flag
Adr = AC.Address(0, 0) 'Zell-Adresse in Formel suchen
Artikel = AC.Cells(1, 2) 'Artikel Text
Lagerort = AC.Cells(1, 3) 'Lagerort
'Zell-Adresse der Artikel Nummer in Tabelle1 Spalte B suchen
Set rFind = .Columns(2).Find(What:="=Tabelle2!" & Adr, After:=.Range("B3"), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchDirection:=xlNext)
'Artikel Text + Lagerort vergleichen ("ok")
If Not rFind Is Nothing Then
If rFind.Cells(1, 2).Value = Artikel And _
rFind.Cells(1, 3).Value = Lagerort Then
.Cells(rFind.Row, PrüfSpaT1) = "ok"
Else 'wenn unstimmig Meldung ausgeben
.Cells(rFind.Row, PrüfSpaT1) = "unstimmig"
u = u + 1 'unstimmige zaehlen
End If
End If
'No Find = neuen Artikel mit Formel anlegen
If rFind Is Nothing Then
'Vorprüfung in Tabelle2 ob Artikel Nummer doppelt vokommt
Set pFind = Tab2.Columns(1).Find(What:=AC.Value, After:=Tab2.Range(Adr), _
LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
'Artikel kommt im Lager doppelt vor !!
If AC.Row AC.Row Then flg = "dopp": _
Tab2.Range(PrüfSpaT2 & pFind.Row) = "doppelt"
If flg Empty Then d = d + 1 'doppelte Zahl
'Artikel als neuen Artikel einfügen
If flg = Empty Then
'Tabelle1 letzte Zeile ermitteln
lZell = .Range("A3").End(xlDown).Row + 1
'Tabelle1 Zeile 4 nach unten kopieren
.Range("A4:G4").Copy .Range("A" & lZell)
'Bestand aus kopierter Zeile löschen
.Range("E" & lZell).Resize(1, 2) = Empty
'Formelzeile 3 gegen Lagerzeile tauschen
.Range("B" & lZell) = "=Tabelle2!A" & AC.Row
.Range("C" & lZell) = "=Tabelle2!B" & AC.Row
.Range("D" & lZell) = "=Tabelle2!C" & AC.Row
'in PrüfSpaT1 als neuen Artikel zeigen
.Range("J" & lZell).Value = "neuer Artikel"
.Range("J" & lZell).Font.ColorIndex = 7
End If
End If
weiter:
Next AC
'ggf. Fehler in Zeile 1/2 anzeigen
If d > 0 Then .[j1] = d & " Artikel doppelt !!": msg = [j1]
If u > 0 Then .[j2] = u & " Artikel unstimmig !!": flg = [j2]
'ggf. Fehlermeldung ausgeben
If d + u > 0 Then MsgBox msg & Chr(10) & flg
'Abgleich wurde fehlerfrei durchgeführt
If d + u = 0 Then MsgBox "Abgleich fehlerfrei beendet"
End With
End Sub
Im Modul3 altes Makro löschen und neu einfügen:
Option Explicit '4.6.2016 Piet für Herber Forum
'Nachtrag für Lösch Routine
Const PrüfSpaT1 = "J" 'Tabelle1 wird Prüfung mit ok markiert
Dim AC As Object, lz1 As Long
'zusammengefasste Makros für Button "T2 Abgleichen"
'Zur Info: Ein Button kann mehrere Makros ausführen
Sub Formel_löschen_und_abgleichen()
'2/3 Makro werden nacheinander ausgeführt
Call gelöschte_Artikel_löschen
Call Formel_mit_Tabelle2_abgleichen
'wenn erfoderlich No Find aktivieren
Call NoFind_Artikel_löschen
End Sub
'dieses Makro löscht alle "#NV" Zeilen (Artikel gelöscht)
Sub gelöschte_Artikel_löschen()
With Worksheets("Tabelle1")
'LastZell in Tabelle 1+2 ermittlen
lz1 = .Range("A3").End(xlDown).Row
'Schleife für Tabellen 1+2 vergleichen
For Each AC In .Range("B2:B" & lz1)
'bei gelöschten Artikeln Formel löschen
If InStr(AC.Formula, "#") Then _
.Rows(AC.Row).Delete Shift:=xlUp
Next AC
End With
End Sub
'dieses Makro löscht alle "No Find" Zeilen (Artikel gelöscht)
Sub NoFind_Artikel_löschen()
Dim PrüfTxt As String
With Worksheets("Tabelle1")
'LastZell in Tabelle 1+2 ermittlen
lz1 = .Range("A3").End(xlDown).Row
'Schleife für Tabellen 1+2 vergleichen
For Each AC In .Range("A2:A" & lz1)
'bei "No Find" Artikeln Formel löschen
PrüfTxt = .Range(PrüfSpaT1 & AC.Row)
If PrüfTxt = "No Find" Then _
.Rows(AC.Row).Delete Shift:=xlUp
Next AC
End With
End Sub