Hallo Heiko!
Leider hab ich noch ein Problem mit dem Macro.
Es wird keine Übereinstimmung gefunden, es kommt die MsgBox "Die HilfsfeldSchärfID Nr ist nicht im Gesamtbestand vorhanden!
Sonst keine Fehlermeldung!
Vieleicht findest Du den Fehler, hoffe Du kannst so mit diesen Modul was anfangen.
Sub InsArchiv()
'Initialisierung der Steuerung
Dim strNameSteuerung As String
strNameSteuerung = Workbooks("SteuerungKaindl.xls").Sheets("INI").[A1] '!§§§ ändern bei anderer Steuerung §§§!
'Aktivierung Monatsrechnung
Dim strLaufwerk As String
Dim strPfadMonBes As String
Dim strPfadArchivM As String
Dim strDateiMonat As String
Dim strMonatSheets1 As String
Dim strMonatSheets2 As String
Dim strMonatSheets6 As String
Dim strDateiBestand As String
Dim strBestandSheets1 As String
strLaufwerk = Workbooks(strNameSteuerung).Sheets("INI").[B3]
strPfadMonBes = Workbooks(strNameSteuerung).Sheets("INI").[B11]
strPfadArchivM = Workbooks(strNameSteuerung).Sheets("INI").[B10]
strDateiMonat = Workbooks(strNameSteuerung).Sheets("INI").[B13]
strMonatSheets1 = Workbooks(strNameSteuerung).Sheets("INI").[B14]
strMonatSheets2 = Workbooks(strNameSteuerung).Sheets("INI").[B15]
strMonatSheets6 = Workbooks(strNameSteuerung).Sheets("INI").[B17]
strDateiBestand = Workbooks(strNameSteuerung).Sheets("INI").[B12]
strBestandSheets1 = Workbooks(strNameSteuerung).Sheets("INI").[B18]
Windows(strDateiMonat).Activate
Sheets(strMonatSheets1).Activate
Dim ArchivName As String
ArchivName = InputBox("Bitte Dateiname angeben! Format: MMJJJJKaindlabrechnung z.B. 062005Kaindlabrechnung")
If Right(ArchivName, 4) = ".xls" Then
ArchivName = Left(ArchivName, Len(ArchivName) - 4)
End If
ActiveWorkbook.SaveAs Filename:=(strLaufwerk & strPfadMonBes & strPfadArchivM & ArchivName & ".xls") _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
'Formelumwandlung
Dim strArchivName As String
strArchivName = ArchivName & ".xls"
Windows(strArchivName).Activate
Sheets(strMonatSheets1).Activate
ActiveSheet.Unprotect
Dim SRow As Long
With Sheets(strMonatSheets1)
For SRow = 4 To 582
Cells(SRow, 1).Value = .Cells(SRow, 1) 'Hilfsfeld
'Cells(SRow, 2).Value = .Cells(SRow, 2) 'Verr. Basis
'Cells(SRow, 3).Value = .Cells(SRow, 3) 'Pos.
'Cells(SRow, 4).Value = .Cells(SRow, 4) 'Werkzeug
'Cells(SRow, 5).Value = .Cells(SRow, 5) 'Durchm.
'Cells(SRow, 6).Value = .Cells(SRow, 6) 'Breite
'Cells(SRow, 7).Value = .Cells(SRow, 7) 'Zähne
'Cells(SRow, 8).Value = .Cells(SRow, 8) 'Zeichn. Nr.
'Cells(SRow, 9).Value = .Cells(SRow, 9) 'Schneidenart
'Cells(SRow, 10).Value = .Cells(SRow, 10) 'Artikelnr.
'Cells(SRow, 11).Value = .Cells(SRow, 11) 'Linie Kaindl Bestandsliste
'Cells(SRow, 12).Value = .Cells(SRow, 12) 'Satz Stück
'Cells(SRow, 13).Value = .Cells(SRow, 13) 'Preis
'Cells(SRow, 19).Value = .Cells(SRow, 19) 'Verr. Datum
'Cells(SRow, 20).Value = .Cells(SRow, 20) 'Inventur Zustand
'Cells(SRow, 21).Value = .Cells(SRow, 21) 'Linie Geliferte Pos.
'Cells(SRow, 22).Value = .Cells(SRow, 22) 'Ausgangsdatum
Next
End With
Windows(strArchivName).Activate
Sheets(strMonatSheets6).Activate
Dim GRow As Long
With Sheets(strMonatSheets6)
For GRow = 586 To 586
Cells(GRow, 6).Value = .Cells(GRow, 6) 'Inventurschärfunge Gesamtbestand Vormonat
Next
End With
'Löschen dr Vorlagezellen
Sheets(strMonatSheets1).Activate
Range("A3:V583").Select
Selection.Sort Key1:=Range("N4"), Order1:=xlAscending, Key2:=Range("O4") _
, Order2:=xlAscending, Key3:=Range("V4"), Order3:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Rows("600:601").Select
Selection.Delete Shift:=xlUp
Range("A4").Select
Sheets(strMonatSheets6).Activate
Selection.AutoFilter Field:=10, Criteria1:="<>"
Sheets(strMonatSheets1).Activate
'Leitz Bestand ändern in Datenbank
Dim lngErsteZeile As Long, lngLetzteZeile As Long
Dim lnfRowFind As Long, lngZeilen As Long
'Erste Zeile wo es los geht in Monatsabrechnung
lngErsteZeile = 4
' Sucht erste leere Zelle in Spalte A (ab A4), das dann minus 1 ergibt die letzte Zeile
' die bearbeitet werden soll.
lngLetzteZeile = Workbooks(strArchivName).Sheets(strMonatSheets1).Range("A4:A65536").Find( _
What:="", LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext).Row - 1
'lngLetzteZeile = Range("A65536").End(xlUp).Offset(0, 0).Row
For lngZeilen = lngErsteZeile To lngLetzteZeile
lnfRowFind = -1
On Error Resume Next
lnfRowFind = Workbooks(strDateiBestand).Sheets(strBestandSheets1).Range("A:A").Find( _
What:=Workbooks(strArchivName).Sheets(strMonatSheets1).Cells(lngZeilen, 1).Text, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row
On Error GoTo 0
If lnfRowFind < 1 Then
MsgBox "Die HilfsfeldSchärfID Nr " & _
Workbooks(strArchivName).Sheets(strMonatSheets1).Cells(lngZeilen, 1).Text & _
" ist nicht im Gesamtbestand vorhanden!", vbCritical
Else
Workbooks(strDateiBestand).Sheets(strBestandSheets1).Cells(lnfRowFind, 18).Value = _
Workbooks(strDateiBestand).Sheets(strBestandSheets1).Cells(lnfRowFind, 18).Value - 1
End If
Next lngZeilen
'Ende der Leitz Bestandsänderung, speichern u. schliessen
Sheets(strMonatSheets2).Activate
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ActiveWorkbook.Save
ActiveWindow.Close
Windows(strDateiBestand).Activate
ActiveWorkbook.Save
ActiveWindow.Close
End Sub
Gruss
Gerhard