Makro Erweiterung

Public Sub Zur_Rechnung_Datenbank_kopieren()

  

  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

         ActiveSheet.Application.ScreenUpdating = False

         Application.Calculation = xlCalculationManual

         Application.EnableEvents = False

   

  Const cstr_wkbQUELLE As String = "D:\Kunden_Datenbank.xlsm"

  

  Const cstr_wksQUELLE As String = "Adressen"

  Const getStrPassWort = "kk"



  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

    wkbQUELLE.Unprotect "tk"

    Set wkbZIEL = Workbooks.Open(cstr_wkbQUELLE)

  End If

  'Worksheet-Variable setzen

  Set wksZIEL = wkbZIEL.Worksheets(cstr_wksQUELLE)

  ActiveSheet.Unprotect "kk"

  

'""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""

 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    bzw. aus Rechnungsprogramm aktive Tabelle

ldtRgDate = .Range("H29").value

'lstrRgNr = .Range("G23").value & " - " & Format(.Range("H23").value, "0000")

lstrRgNr = .Range("H24").value

End With



wkbZIEL.Activate

    

        ' wenn Rechnungs-Nummer vorhanden

           With Sheets("Adressen")                                           '  wkbZIEL.("Adressen")

            For lloRow = 3 To .Cells(.Rows.Count, 14).End(xlUp).Row          '  9 ist Datum gleich i

                If .Range("N" & lloRow).value = ldtRgDate Then

                    If InStr(.Range("O" & lloRow).value, lstrRgNr) > 0 Then   'J = Rechnungsnummer nach altem Ablauf

                        lboOK = True

                    ' MsgBox "schon vorhanden"

                        Exit For

                    End If

                End If

            Next

'          Stop

        If lboOK = True Then



'------ hier Meldung ob vorhanden -----------------------------

MsgBox "Achtung ! Kundenist in der ""##_Rechnungs-Datenbank"" mit" _

            & " der 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     

            ' jab hier wird kopiert !!!

 'Suchergebnis prüfen: strSUCH nicht gefunden: Am Ende Anfügen

  If rngZIEL Is Nothing Then

    Set rngZIEL = wksZIEL.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)  'Offset(1, 0  = 1 zeile drunter

  End If

   

 

    wksZIEL.Unprotect "tk"                 '(getStrPassWort)

    wksQUELLE.Unprotect "sommer"            '10.01.2025

   

   wksQUELLE.Range("O11:O24").Copy



   rngZIEL.Offset(0, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True



   '---- Rechnungskorrektur ---- rein 08.01.25 ---

    wksQUELLE.Range("P34").Copy

    rngZIEL.Offset(0, 11).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

        :=False, Transpose:=False

   rngZIEL.Offset(0, 11).Font.Color = -16776961



  '---- Rg. Netto -------

  wksQUELLE.Range("E371").Copy

  rngZIEL.Offset(0, 12).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

        :=False, Transpose:=False

 

  '-------- Datum --------------

  wksQUELLE.Range("H29").Copy

  rngZIEL.Offset(0, 13).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

        :=False, Transpose:=False



  '-------- Rg. Nummer ------------

    wksQUELLE.Range("H24").Copy

    rngZIEL.Offset(0, 14).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

        :=False, Transpose:=False

      

     '-------- welche firma--------------

  wksQUELLE.Range("P31").Copy

  rngZIEL.Offset(0, 15).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

        :=False, Transpose:=False



      '-------- Wer erstellt -------------

  wksQUELLE.Range("e23").Copy

  rngZIEL.Offset(0, 16).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

        :=False, Transpose:=False

        

      '-------- wurde eRechnung erstellt --------------

  wksQUELLE.Range("i1").Copy

  rngZIEL.Offset(0, 17).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

        :=False, Transpose:=False





  wksZIEL.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:=getStrPassWort

            Application.CutCopyMode = False



  wkbQUELLE.Activate        'Datei

  wksQUELLE.Activate        'Sheet

  wksQUELLE.Range("O12").Select

  End If

    End With

         ActiveSheet.Application.ScreenUpdating = True

         Application.Calculation = xlCalculationManual

         Application.EnableEvents = True

  

        wkbZIEL.Save

        wkbZIEL.Close True

  

End Sub