|
So sieht mein Code aktuell aus:
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 ("xxx")
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("A3:D2000").Cells.ClearContents
Set rngSrc = Range("F3:F2000")
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(2, 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 ("xxx")
Next Blatt
Application.ScreenUpdating = True
End Sub
|