Hallo,

ich habe bei dem unten stehenden Code das Problem, dass Minuszahlen beim summieren nicht berücksichtigt werden. 

Beispiel: Wert1: 9000 Wert2: -9000 sollte eigentlich 0 ergeben, aber das Ergebnis ist leider 9000

Wer kann da evtl. helfen ?

Public Sub transfer()

   Dim i   As Long
   Dim rs  As Object
   Dim Blatt As Worksheet
   Dim rngZelle As Range, rngSrc As Range
    
    For Each Blatt In ActiveWorkbook.Worksheets
      Blatt.Unprotect ("lothar")
    Next Blatt

If MsgBox("Willst du die Berechnung starten? JA/NEIN", vbYesNo) = vbYes Then

Set rs = CreateObject("ADODB.Recordset")
     
    
    
rs.Open ActiveConnection:="Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml""", _
        Source:="SELECT [Material] , sum([Book quantity]) As Korrektur, sum([Difference Quantity]) As Differenz, sum([Difference Quantity1]) As Betrag " & _
                "FROM (SELECT * FROM `Daten$` WHERE [Difference Quantity1] >= 1000) " & _
                "Group By [Material]"
                      
        
    Worksheets("Ergebnis").Range("A2:D80").Cells.ClearContents
   
        
    Set rngSrc = Range("F2:F80")
    If Not rngSrc.MergeCells Then
        rngSrc.ClearContents
    Else
        For Each rngZelle In rngSrc
            rngZelle.MergeArea.ClearContents
        Next
    End If
    
    Worksheets("Ergebnis").Range("A2").CopyFromRecordset rs
     
     
 
    Do
        Worksheets("Ergebnis").Cells(1, i + 1).Value = rs.Fields(i).Name
        i = i + 1
    Loop While i < rs.Fields.Count
     
     
    rs.Close
    
    Worksheets("Ergebnis").Activate
     
MsgBox "Übertragung erfolgreich !!!"

Else

MsgBox "Vorgang abgebrochen"
Worksheets("Daten").Activate

End If

    For Each Blatt In ActiveWorkbook.Worksheets
      Blatt.Protect ("lothar")
    Next Blatt

Application.ScreenUpdating = True

End Sub