Hallo,
anbei das Makro:
Dim wksQUELLE As Worksheet 'Quell-Worksheet
Dim wksZIEL As Worksheet 'Ziel-Worksheet
Dim wkbZIEL As Workbook, wkbQUELLE As Workbook
Dim rngZIEL As Range
Dim strSUCH As String
Const cstr_wkbQUELLE As String = "\\Lager\d\#_Lager_Rechnungen.xlsm"
Const cstr_wksQUELLE As String = "Rechnungen"
Const getStrPassWort = "wb"
Set wkbQUELLE = ActiveWorkbook
Set wksQUELLE = ActiveSheet
Application.ScreenUpdating = False
On Error Resume Next
Set wkbZIEL = Workbooks(cstr_wkbQUELLE)
On Error GoTo 0
If wkbZIEL Is Nothing Then
Set wkbZIEL = Workbooks.Open(cstr_wkbQUELLE)
End If
Set wksZIEL = wkbZIEL.Worksheets(cstr_wksQUELLE)
'""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
Dim lFile
Dim lloRow As Long, ldtRgDate As Date, lstrRgNr As String, lboOK As Boolean, lloRNext As Long
Dim wks, shs, pshDB
With wksQUELLE 'ActiveSheet
ldtRgDate = .Range("J18").Value
lstrRgNr = .Range("I23").Value & " - " & Format(.Range("J23").Value, "00 - 0000")
End With
wkbZIEL.Activate
With Sheets("Rechnungen") ' wkbZIEL.("Rechnungen")
For lloRow = 3 To .Cells(.Rows.Count, 9).End(xlUp).Row
MsgBox "Zeile " & lloRow
MsgBox "Bedingung1: " & (Sheets("Adressen").Range("I" & lloRow).Value = ldtRgDate)
If .Range("I" & lloRow).Value = ldtRgDate Then
MsgBox "Bedingung2: " & (InStr(Sheets("Adressen").Range("J" & lloRow).Value, lstrRgNr) > 0)
If InStr(.Range("J" & lloRow).Value, lstrRgNr) > 0 Then
lboOK = True
Exit For
End If
End If
Next
If lboOK = True Then
MsgBox "Die Rg-Nr ''" & lstrRgNr & "'' mit dem Datum ''" & ldtRgDate & "'' ist in Ihrer Datenbank vorhanden." _
& vbCrLf & vbCrLf & "Es werden die Daten nicht kopiert !", vbInformation, "Hinweis"
wkbQUELLE.Activate
Else
'' Dim lFile
'' Dim lloRow As Long, ldtRgDate As Date, lstrRgNr As String, lboOK As Boolean, lloRNext As Long
'' Dim wks, shs, pshDB
' With wksQUELLE
' ldtRgDate = .Range("J18").Value
' lstrRgNr = .Range("I23").Value & " - " & Format(.Range("J23").Value, "0000")
' End With
' wkbZIEL.Activate
' With Sheets("Rechnungen") ' wkbZIEL.("Rechnungen")
' For lloRow = 3 To .Cells(.Rows.Count, 9).End(xlUp).Row
' If .Range("I" & lloRow).Value = ldtRgDate Then
' If InStr(.Range("J" & lloRow).Value, lstrRgNr) > 0 Then
' lboOK = True
' Exit For
' End If
' End If
' Next
' If lboOK = True Then
' MsgBox "Die Rg-Nr ''" & lstrRgNr & "'' mit dem Datum ''" & ldtRgDate & "'' ist in Ihrer Datenbank vorhanden." _
' & vbCrLf & vbCrLf & "Es werden die Daten nicht kopiert !", vbInformation, "Hinweis"
wkbQUELLE.Activate
' Else
'""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
' jetzt wird kopiert !!!
'Begriff suchen
' strSUCH = wksQuelle.Range("C13")
' Set rngZiel = wksZiel.Range("B:B").Find(What:=strSUCH, After:=wksZIEL.Range("B3"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
'Suchergebnis prüfen: strSUCH nicht gefunden: Am Ende Anfügen
If rngZIEL Is Nothing Then
Set rngZIEL = wksZIEL.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0) 'Offset(1, 0 = 1 zeile drunter
End If
'übertragen
wksZIEL.Unprotect "wb"
wksQUELLE.Range("C12:C18").Copy
rngZIEL.Offset(0, -1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
'---- Rg. Netto -------
wksQUELLE.Range("E371").Copy
rngZIEL.Offset(0, 5).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'-------- Datum ---------------
wksQUELLE.Range("J18").Copy
rngZIEL.Offset(0, 6).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'-------- Rg. Nummer ---------------
wksQUELLE.Range("B23").Copy
rngZIEL.Offset(0, 9).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
rngZIEL.Offset(0, 8).FormulaR1C1 = "=RIGHT(RC[1],10)"
rngZIEL.Offset(0, 8).Copy
rngZIEL.Offset(0, 7).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
rngZIEL.Offset(0, 8).ClearContents
rngZIEL.Offset(0, 9).ClearContents
'-------- welche firma ---------------
wksQUELLE.Range("i1").Copy
rngZIEL.Offset(0, 8).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'-------- Wer erstellt ---------------
wksQUELLE.Range("e23").Copy
rngZIEL.Offset(0, 9).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
wksZIEL.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="wb 'getStrPassWort
Application.CutCopyMode = False
wkbQUELLE.Activate
wksQUELLE.Activate
wksQUELLE.Range("C12").Select
End If
End With
Application.ScreenUpdating = True
'' ActiveWorkbook.SaveAs Filename:="D:\#_Lager_Rechnungen.xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
wkbZIEL.Close True
mfg walter b