Hallo Karl Otto,
hier wäre der Code.
wäre toll wenn Du mir helfen könntest !
Karl
Sub Abgleich_Preisliste_WG_2_mit_AS400_Daten()
Dim ArtikelBereich As Range
Dim fehl As Boolean
Dim letzteZeile As Long
Dim wbQ As Workbook
Dim wbZ As Workbook
Dim wbProtokoll As Workbook
Dim wsQ As Worksheet
Dim wsZ As Worksheet
Dim wsNgf As Worksheet
Dim wsGf As Worksheet
Dim zeileQ As Long
Dim zeileZ As Long
Dim zeileNgf As Long
Dim zeileGf As Long
Dim PfadAS400 As String
Dim NL As String
Dim Preislistennummer As String
Dim alleworkbooks As Workbook
' Festlegen des NL - bezogenen Datenstruktur (Pfad, NL-Nummer)
PfadAS400 = Range(Cells(8, 22), Cells(8, 22)).Value
NL = Range(Cells(7, 22), Cells(7, 22)).Value
On Error GoTo Errorhandler1
'Buttons Sortimentsverwaltung einblenden
Application.CommandBars("sortimentsverwaltung").Enabled = True
Application.CommandBars("sortimentsverwaltung").Visible = True
' Bildschirmanzeige ausschalten
Application.ScreenUpdating = False
' Fehlermeldung unterbinden
' Application.DisplayAlerts = False
' Statusleistenanzeige einschalten
Application.StatusBar = "Ihre Preisliste wird mit den AS400 Daten abgeglichen....Bitte einen Moment warten !"
' Zieldatei öffnen
' Set wbZ = Workbooks.Open(Filename:=PfadAS400 & ":\PRSLISTE\Intern\NL" & NL & "\PREISE\P9999" & NL & ".CSV")
' On Error GoTo Errorhandler2
Set wbZ = Workbooks.Open(Filename:=ThisWorkbook.Path & "\Arbeitsdateien\A 010 Stammdaten aus AS 400\Interne Daten\P9999" & NL & ".csv")
' Zielsheet definieren
Set wsZ = wbZ.Worksheets(1)
' Quelldatei öffnen
Set wbQ = Workbooks.Open(Filename:=ThisWorkbook.Path & "\Arbeitsdateien\B 010 Bearbeitung Preislistenstruktur\PL Struktur WG 2")
' In Quelldatei das arbeiten mit der Gliederung trotz Blattschutz ermöglichen
For i = 1 To Sheets.Count
Sheets(i).Select
ActiveSheet.Unprotect Password:="plschutz"
ActiveSheet.Protect Password:="plschutz", DrawingObjects:=True, Contents:=True, Scenarios:=True
' nachfolgende Befehle erlauben das Arbeiten mit der Gliederung
ActiveSheet.Protect UserInterfaceOnly:=True
ActiveSheet.EnableOutlining = True ' Für Gliederung
ActiveSheet.EnableAutoFilter = True ' Für AutoFilter
Next i
Sheets(1).Select
' Protokoll erstellen welche Artikel nicht zugeordnet werden konnten
Set wbProtokoll = Workbooks.Open(Filename:=ThisWorkbook.Path & "\Arbeitsdateien\D 010 Protokolle\Protokoll Datenabgleich Sortiment.xls")
Set wsNgf = wbProtokoll.Worksheets("Keine AS400 Preise vorhanden")
' Protokollsheet leeren
wsNgf.Range(wsNgf.Cells(1, "A"), wsNgf.Cells(65000, "Z")).ClearContents
' Überschriften im Protokollsheet festlegen
wsNgf.Cells(1, "A") = "Artikelnummer"
wsNgf.Cells(1, "B") = "Register"
wsNgf.Cells(1, "C") = "Zeile"
zeileNgf = 2
' Daten überprüfen, Gefundene Artikel in Zieldatei markieren, nichtgefundene in Protokolldatei festhalten
letzteZeile = wsZ.Cells(wsZ.rows.Count, 1).End(xlUp).Row
wsZ.Range(wsZ.Cells(2, "AH"), wsZ.Cells(letzteZeile, "AH")).ClearContents
For Each wsQ In wbQ.Worksheets
letzteZeile = wsZ.Cells(wsZ.rows.Count, 1).End(xlUp).Row
Set ArtikelBereich = wsZ.Range("A2", wsZ.Cells(letzteZeile, 1))
letzteZeile = wsZ.Cells(wsZ.rows.Count, 1).End(xlUp).Row
For zeileQ = 3 To letzteZeile
If IsNumeric(wsQ.Cells(zeileQ, 1)) Then
'If wsZ.Cells(zeileZ, 1) <> 0 Then
If wsQ.Cells(zeileQ, 1) > 100000000000000# Then
zeileZ = ZeilenNr(Suchbegriff:=wsQ.Cells(zeileQ, 1), _
Datenbereich:=ArtikelBereich, _
Fehler:=fehl) + 1
If Not fehl Then
'Befehlszeile die auch formate mitkopiert (AUSGESCHALTEN)
'wsQ.Range(wsQ.Cells(zeileQ, "K"), wsQ.Cells(zeileQ, "AA")).Copy Destination:=wsZ.Cells(zeileZ, "G")
' Markieren der gefundenen Artikel in Zieldatei(wsz = Worksheet Ziel / wsQ = worksheet Quelle)
wsZ.Cells(zeileZ, "AH") = 1
Else
' Protokoll über Daten erstellen, die keine Preise in der AS400 haben, aber in der Preisliste vorhanden sind
wsNgf.Cells(zeileNgf, "A") = wsQ.Cells(zeileQ, "A")
wsNgf.Cells(zeileNgf, "B") = wsQ.Name
wsNgf.Cells(zeileNgf, "C") = zeileQ
zeileNgf = zeileNgf + 1
End If
End If
End If
Next zeileQ
Next wsQ
' Tabellenblatt "AS400 Stammdaten" in Datei Protokoll leeren
Windows("Protokoll Datenabgleich Sortiment.xls").Activate
Sheets("AS 400 Stammdaten").Select
Range("A2:AH15000").ClearContents
Range("A2").Select
' Sheets "AS400 Stammdaten" von Datei "AS400 Stammdaten in Datei "Protokoll" kopieren
Windows("P9999" & NL & ".csv").Activate
Sheets("P9999" & NL).Select
'Filter auf alle Artikel der Warengruppe 1 setzen
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:=">200000000000000", Operator:= _
xlAnd, Criteria2:="<300000000000000"
Windows("P9999" & NL & ".csv").Activate
Range("A2:J15000").Select
Selection.Copy
Windows("Protokoll Datenabgleich Sortiment.xls").Activate
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Windows("P9999" & NL & ".csv").Activate
Range("AH2:AH15000").Select
Range("AH15000").Activate
Application.CutCopyMode = False
Selection.Copy
Windows("Protokoll Datenabgleich Sortiment.xls").Activate
Range("AH2").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("A2").Select
Windows("P9999" & NL & ".csv").Activate
' Zwischenspeider löschen
Application.CutCopyMode = False
ActiveWorkbook.Close savechanges:=False
Windows("Protokoll Datenabgleich Sortiment.xls").Activate
Range("A2").Select
' Bildschirmanzeige einschalten
Application.ScreenUpdating = True
' Fehlermeldung unterbinden
Application.DisplayAlerts = True
' Zwischenspeider löschen
Application.CutCopyMode = False
' Statusleiste zurücksetzen
Application.StatusBar = False
Sheets("AS 400 Stammdaten").Select
Range("A2").Select
Beep
MsgBox "Die AS 400 Daten wurden überprüft, neue Artikel orange markiert"
Sheets("keine AS400 Preise vorhanden").Select
Range("A2").Select
MsgBox "Artikel die in der AS 400 nicht gepflegt sind finden Sie im Register KEINE AS 400 Preise vorhanden"
Exit Sub
Errorhandler2:
MsgBox "Die AS400 Daten wurden nicht gefunden.", vbCritical, "AS400 - Datenfehler:"
Application.StatusBar = Done
Windows("Sortimentsverwaltung.xls").Activate
For Each alleworkbooks In Workbooks
If alleworkbooks.Name <> ThisWorkbook.Name Then
alleworkbooks.Close savechanges:=False
End If
Next alleworkbooks
Exit Sub
Errorhandler1:
MsgBox "Es ist ein Fehler aufgetreten. Der Vorgang wird abgebrochen ", vbCritical, "Fehler:"
Application.StatusBar = Done
Windows("Sortimentsverwaltung.xls").Activate
For Each alleworkbooks In Workbooks
If alleworkbooks.Name <> ThisWorkbook.Name Then
alleworkbooks.Close savechanges:=False
End If
Next alleworkbooks
End Sub