Option Compare Database Option Explicit Sub GebundenBerechnen(Jahr1 As Long, SortenattributeBeiFlächenbindungOptional As Boolean, GebundenBerücksichtigen As Boolean) Dim db1 As Database Dim rs1 As Recordset Dim rs2 As Recordset Dim rs3 As Recordset Dim actMGNR As Long Dim actSNR As String Dim actSANR As String Dim rsSANR As String Dim actLieferrecht As Double Dim actLieferrecht_Attribute(0 To 255) As Double Dim actLieferungGebunden As Double Dim actBetrag As Double Dim GewichtGebunden As Double Dim GewichtGebundenGrundsorte As Double Dim test1 Dim ErgebnisGewicht As Double Dim ErgebnisBetrag As Double Dim ErgebnisGebunden As Double Dim ErgebnisDatensaetze As Double Dim ErgebnisAktDatensatz As Double Dim query1 As String Dim query2 As String Dim zwi Dim maxertrag As Double Dim KgProHa Dim attribute_count As Long Dim i As Long Dim j As Long Dim ImmerUngebunden As Boolean DoCmd.Hourglass True 'maxertrag = GetParameter("MAXERTRAG") Set db1 = CurrentDb query1 = "SELECT * FROM TSorten INNER JOIN (TMitglieder INNER JOIN TLieferungen ON TMitglieder.MGNR = TLieferungen.MGNR) ON TSorten.SNR = TLieferungen.SNR WHERE Oechsle>0 AND TLieferungen.SNR>'' AND Year([Datum]) = " + Format(Jahr1) + " ORDER BY TLieferungen.MGNR, TLieferungen.SNR, TLieferungen.SANR DESC, TLieferungen.LINR;" 'query1 = "SELECT * FROM (TSorten INNER JOIN (TMitglieder INNER JOIN TLieferungen ON TMitglieder.MGNR = TLieferungen.MGNR) ON TSorten.SNR = TLieferungen.SNR) LEFT JOIN TSortenAttribute ON TLieferungen.SANR = TSortenAttribute.SANR WHERE Oechsle>0 AND TLieferungen.SNR>'' AND Year([Datum]) = " + Format(jahr1) + " ORDER BY TLieferungen.MGNR, TLieferungen.SNR, TLieferungen.SANR DESC, TLieferungen.LINR;" Set rs1 = db1.OpenRecordset(query1) actMGNR = -1 actSNR = "" actSANR = "" While Not rs1.EOF rs1.Edit If actMGNR <> rs1![TLieferungen.MGNR] Then ' Nächstes Mitglied actMGNR = rs1![TLieferungen.MGNR] actSNR = "----" actSANR = "----" End If If Not IsNull(rs1![SANR]) And rs1!SANR <> "" Then rsSANR = UCase(rs1![SANR]) ImmerUngebunden = DFirst("ImmerUngebunden", "TSortenAttribute", "SANR='" + rsSANR + "'") Else rsSANR = "" ImmerUngebunden = False End If GewichtGebunden = 0 GewichtGebundenGrundsorte = 0 If SortenattributeBeiFlächenbindungOptional = True Then 'A Sortenattribute in Flaechenbindung optional actSANR = rsSANR 'Feststellen der Lieferrechte bei Sortenwechsel If actSNR <> UCase(rs1![TLieferungen.SNR]) Then actSNR = UCase(rs1![TLieferungen.SNR]) KgProHa = DFirst("kgproHa", "TSorten", "SNR='" + actSNR + "'") 'maxertrag für Grundsorte bestimmen If Not IsNull(KgProHa) And KgProHa > 0 Then maxertrag = KgProHa Else maxertrag = GetParameter("MAXERTRAG") End If 'Lieferrecht für Grundsorte errechnen zwi = DSum("Flaeche", "TFlaechenbindungen", "MGNR=" + Format(actMGNR) + " AND SNR='" + Format(actSNR) + "' AND [Von]<=" + Format(Jahr1) + " AND (Bis>=" + Format(Jahr1) + " OR Isnull(Bis))") If IsNull(zwi) Then actLieferrecht = 0 zwi = 0 Else actLieferrecht = zwi * maxertrag / 10000 End If 'maxertrag für jedes Attribut bestimmen Set rs3 = db1.OpenRecordset("SELECT * FROM TSortenattribute ORDER BY SANR") i = 0 While Not rs3.EOF KgProHa = rs3("kgproha") If Not IsNull(KgProHa) And KgProHa > 0 Then actLieferrecht_Attribute(i) = zwi * KgProHa / 10000 Else actLieferrecht_Attribute(i) = zwi * GetParameter("MAXERTRAG") / 10000 End If rs3.MoveNext i = i + 1 Wend rs3.Close attribute_count = i End If If rs1!QSNR >= 3 And (rs1!gebunden = True Or GebundenBerücksichtigen = False) Then If actSANR = "" Then 'Grundsorte If rs1!Gewicht < actLieferrecht Then ' Alles GewichtGebunden = rs1!Gewicht actLieferrecht = actLieferrecht - GewichtGebunden 'auch für alle Attribute Lieferrecht reduzieren For i = 0 To attribute_count - 1 actLieferrecht_Attribute(i) = actLieferrecht_Attribute(i) - GewichtGebunden Next i Else If actLieferrecht > 0 Then ' Ein Teil GewichtGebunden = actLieferrecht actLieferrecht = 0 'auch für alle Attribute Lieferrecht reduzieren For i = 0 To attribute_count - 1 actLieferrecht_Attribute(i) = actLieferrecht_Attribute(i) - GewichtGebunden Next i Else ' Kein geb. Lieferrecht mehr übrig GewichtGebunden = 0 End If End If Else 'Sortenattribut 'Nur wenn Attribut nicht ohnehin Ungebunden If ImmerUngebunden = False Then 'richtigen Eintrag finden Set rs3 = db1.OpenRecordset("SELECT * FROM TSortenattribute ORDER BY SANR") j = 0 While Not rs3.EOF And rs3("SANR") <> actSANR rs3.MoveNext j = j + 1 Wend rs3.Close If j > attribute_count Then 'error MsgBox ("Fehler bei Attributen!") End If If rs1!Gewicht < actLieferrecht_Attribute(j) Then ' Alles GewichtGebunden = rs1!Gewicht actLieferrecht = actLieferrecht - GewichtGebunden 'auch für alle Attribute Lieferrecht reduzieren For i = 0 To attribute_count - 1 actLieferrecht_Attribute(i) = actLieferrecht_Attribute(i) - GewichtGebunden Next i Else If actLieferrecht_Attribute(j) > 0 Then ' Ein Teil GewichtGebunden = actLieferrecht_Attribute(j) 'Lieferrecht bei Grundsorte reduzieren actLieferrecht = actLieferrecht - GewichtGebunden 'auch für alle Attribute Lieferrecht reduzieren For i = 0 To attribute_count - 1 actLieferrecht_Attribute(i) = actLieferrecht_Attribute(i) - GewichtGebunden Next i Else ' Kein geb. Lieferrecht mehr übrig GewichtGebunden = 0 End If End If 'Versuche, Rest auf Grundsorte zu verbuchen If GewichtGebunden < rs1!Gewicht And actLieferrecht > 0 Then If rs1!Gewicht - GewichtGebunden < actLieferrecht Then ' Alles GewichtGebundenGrundsorte = rs1!Gewicht - GewichtGebunden actLieferrecht = actLieferrecht - GewichtGebundenGrundsorte 'auch für alle Attribute Lieferrecht reduzieren For i = 0 To attribute_count - 1 actLieferrecht_Attribute(i) = actLieferrecht_Attribute(i) - GewichtGebundenGrundsorte Next i Else If actLieferrecht > 0 Then ' Ein Teil GewichtGebundenGrundsorte = actLieferrecht actLieferrecht = 0 'auch für alle Attribute Lieferrecht reduzieren For i = 0 To attribute_count - 1 actLieferrecht_Attribute(i) = actLieferrecht_Attribute(i) - GewichtGebundenGrundsorte Next i Else ' Kein geb. Lieferrecht mehr übrig GewichtGebundenGrundsorte = 0 End If End If End If End If End If Else ' Kein Qualitätswein GewichtGebunden = 0 End If 'MsgBox (Format(rs1!Gewicht) + " " + Format(rs1!Gebunden) + " " + Format(GewichtGebunden)) If IsNull(GewichtGebunden) Then GewichtGebunden = 0 If IsNull(GewichtGebundenGrundsorte) Then GewichtGebundenGrundsorte = 0 'rounding If CLng(GewichtGebunden) < GewichtGebunden Then GewichtGebunden = CLng(GewichtGebunden) + 1 Else GewichtGebunden = CLng(GewichtGebunden) End If GewichtGebundenGrundsorte = Int(GewichtGebundenGrundsorte) rs1!BGewichtGebunden = GewichtGebunden rs1!BGewichtGebundenGrundsorte = GewichtGebundenGrundsorte rs1.Update Else 'B Strikt = Sortenattribute in Flaechenbindung NICHT optional 'Feststellen der Lieferrechte bei Sorten oder Attributswechsel If actSNR <> UCase(rs1![TLieferungen.SNR]) Or (actSANR <> rsSANR) Then ' Nächste Sorte oder Attribut actSNR = UCase(rs1![TLieferungen.SNR]) actSANR = rsSANR 'maxertrag setzen If actSANR <> "" Then 'from Sortenattribut KgProHa = DFirst("kgproHa", "TSortenattribute", "SANR='" + rsSANR + "'") If Not IsNull(KgProHa) And KgProHa > 0 Then maxertrag = KgProHa Else maxertrag = GetParameter("MAXERTRAG") End If zwi = DSum("Flaeche", "TFlaechenbindungen", "MGNR=" + Format(actMGNR) + " AND SNR='" + Format(actSNR) + "' AND SANR='" + actSANR + "' AND [Von]<=" + Format(Jahr1) + " AND (Bis>=" + Format(Jahr1) + " OR Isnull(Bis))") * maxertrag / 10000 Else 'from Sorte If Not IsNull(rs1!KgProHa) And rs1!KgProHa > 0 Then maxertrag = rs1!KgProHa Else maxertrag = GetParameter("MAXERTRAG") End If zwi = DSum("Flaeche", "TFlaechenbindungen", "MGNR=" + Format(actMGNR) + " AND SNR='" + Format(actSNR) + "' AND (Isnull(SANR) or SANR='') AND [Von]<=" + Format(Jahr1) + " AND (Bis>=" + Format(Jahr1) + " OR Isnull(Bis))") * maxertrag / 10000 End If If IsNull(zwi) Then actLieferrecht = 0 Else actLieferrecht = zwi End If actLieferungGebunden = 0 End If ' actLieferungGewicht 'Wieviel ist gebunden ? If rs1!QSNR >= 3 And (rs1!gebunden = True Or GebundenBerücksichtigen = False) And ImmerUngebunden = False Then If rs1!Gewicht < actLieferrecht - actLieferungGebunden Then ' Alles GewichtGebunden = rs1!Gewicht actLieferungGebunden = actLieferungGebunden + GewichtGebunden Else If actLieferungGebunden < actLieferrecht Then ' Ein Teil GewichtGebunden = actLieferrecht - actLieferungGebunden actLieferungGebunden = actLieferrecht Else ' Kein geb. Lieferrecht mehr übrig GewichtGebunden = 0 End If End If Else ' Kein Qualitätswein GewichtGebunden = 0 End If 'MsgBox (Format(rs1!Gewicht) + " " + Format(rs1!Gebunden) + " " + Format(GewichtGebunden)) If IsNull(GewichtGebunden) Then GewichtGebunden = 0 'round up If CLng(GewichtGebunden) < GewichtGebunden Then GewichtGebunden = CLng(GewichtGebunden) + 1 Else GewichtGebunden = CLng(GewichtGebunden) End If rs1!BGewichtGebunden = GewichtGebunden rs1!BGewichtGebundenGrundsorte = 0 rs1.Update End If rs1.MoveNext Wend rs1.Close DoCmd.Hourglass False End Sub Sub Auszahlung2015_MwStUmstellen() Dim db1 As Database Dim rs1 As Recordset Dim rs2 As Recordset Dim faktor As Double Dim Buchführend As Boolean Dim summe1 As Double Dim summe2 As Double Set db1 = CurrentDb '1. originaldaten sichern db1.Execute ("DROP TABLE xTempLieferungen") db1.Execute ("CREATE TABLE xTempLieferungen (LINR Integer, MGNR Integer, BTeilzahlung1 DOUBLE, BBetragGebunden DOUBLE, BBetragUngebunden DOUBLE,BTeilzahlung1_neu DOUBLE, BBetragGebunden_neu DOUBLE, BBetragUngebunden_neu DOUBLE, Korrekturbetrag DOUBLE,GesamtBrutto DOUBLE, GesamtBrutto_neu DOUBLE, GesamtBrutto_neu_korrigiert DOUBLE)") db1.Execute ("DELETE * FROM xTempLieferungen") Set rs1 = db1.OpenRecordset("SELECT * FROM TLieferungen where datum>Datevalue('01.01.2015') order by LINR") Set rs2 = db1.OpenRecordset("xTempLieferungen") While Not rs1.EOF rs2.AddNew rs2("LINR") = rs1("LINR") rs2("MGNR") = rs1("MGNR") rs2("BTeilzahlung1") = rs1("BTeilzahlung1") rs2("BBetragGebunden") = rs1("BBetragGebunden") rs2("BBetragUngebunden") = rs1("BBetragUngebunden") rs2.Update rs1.MoveNext Wend rs1.Close rs2.Close '2. nettobeträge korrigieren Set rs1 = db1.OpenRecordset("SELECT TLieferungen.* FROM TLieferungen WHERE MGNR>0 AND datum>Datevalue('01.01.2015') order by LINR") While Not rs1.EOF Buchführend = DFirst("Buchführend", "TMitglieder", "MGNR=" + Format(rs1("MGNR"))) 'If buchführend Then ' faktor = 1 'Else faktor = 1.13 / 1.12 'End If Set rs2 = db1.OpenRecordset("SELECT * FROM xTempLieferungen WHERE LINR=" + Format(rs1("LINR"))) rs2.Edit rs2("BTeilzahlung1_neu") = rs1("BTeilzahlung1") * faktor rs2("BBetragGebunden_neu") = rs1("BBetragGebunden") * faktor rs2("BBetragUngebunden_neu") = rs1("BBetragUngebunden") * faktor rs2("Korrekturbetrag") = 0 rs2.Update rs1.MoveNext Wend rs1.Close rs2.Close '3. runden für gleichen Betrag Set rs1 = db1.OpenRecordset("SELECT DISTINCT MGNR FROM TLieferungen WHERE MGNR>0 AND MGNR NOT IN (SELECT MGNR FROM TMitglieder WHERE Buchführend=True) AND datum>Datevalue('01.01.2015') order by MGNR") While Not rs1.EOF summe1 = DSum("BTeilzahlung1", "xTempLieferungen", "MGNR=" + Format(rs1("MGNR"))) summe2 = 0 If summe1 <> 0 Then Set rs2 = db1.OpenRecordset("SELECT * FROM xTempLieferungen WHERE MGNR=" + Format(rs1("MGNR"))) While Not rs2.EOF rs2.Edit rs2("BTeilzahlung1_neu") = Runden(rs2("BTeilzahlung1_neu"), 2) If Not IsNull(rs2("BBetragGebunden_neu")) Then rs2("BBetragGebunden_neu") = Runden(rs2("BBetragGebunden_neu"), 3) End If If Not IsNull(rs2("BBetragUngebunden_neu")) Then rs2("BBetragUngebunden_neu") = Runden(rs2("BBetragUngebunden_neu"), 3) End If summe2 = summe2 + rs2("BTEilzahlung1_neu") rs2.Update rs2.MoveNext Wend rs2.MovePrevious 'letzten Eintrag auf korrekte Summe korrigieren rs2.Edit 'rs2("Korrekturbetrag") = (summe2 * 1.12 - summe1 * 1.13) / 1.12 rs2("Korrekturbetrag") = Runden((Runden(summe2 * 1.12, 2) - Runden(summe1 * 1.13, 2)) / 1.12, 2) rs2("GesamtBrutto") = Runden(summe1 * 1.13, 2) rs2("GesamtBrutto_neu") = Runden(summe2 * 1.12, 2) rs2("GesamtBrutto_neu_korrigiert") = Runden((summe2 - rs2("Korrekturbetrag")) * 1.12, 2) If rs2("GesamtBrutto_neu_korrigiert") > rs2("GesamtBrutto") Then rs2("Korrekturbetrag") = rs2("Korrekturbetrag") + 0.01 rs2("GesamtBrutto_neu_korrigiert") = Runden((summe2 - rs2("Korrekturbetrag")) * 1.12, 2) End If If rs2("GesamtBrutto_neu_korrigiert") < rs2("GesamtBrutto") Then rs2("Korrekturbetrag") = rs2("Korrekturbetrag") - 0.01 rs2("GesamtBrutto_neu_korrigiert") = Runden((summe2 - rs2("Korrekturbetrag")) * 1.12, 2) End If rs2.Update rs2.Close End If rs1.MoveNext Wend rs1.Close 'Exit Sub '4. Rückübertragung in TLieferungen Set rs1 = db1.OpenRecordset("SELECT * FROM xTempLieferungen WHERE BTeilzahlung1>0 ORDER BY LINR") While Not rs1.EOF Set rs2 = db1.OpenRecordset("SELECT * FROM TLieferungen where LINR=" + Format(rs1("LINR"))) If Not rs2.EOF Then rs2.Edit rs2("BTeilzahlung1") = Runden(rs1("BTeilzahlung1_neu") - rs1("Korrekturbetrag"), 2) rs2("BBetragGebunden") = rs1("BBetragGebunden_neu") rs2("BBetragUngebunden") = rs1("BBetragUngebunden_neu") rs2.Update End If rs2.Close rs1.MoveNext Wend rs1.Close End Sub Sub Auszahlung2015_NettoPreiseProKg_anheben() Dim db1 As Database Dim rs1 As Recordset Dim faktor As Double Set db1 = CurrentDb faktor = 1.13 / 1.12 Set rs1 = db1.OpenRecordset("SELECT * FROM TAuszahlungSorten WHERE AZNR=140") While Not rs1.EOF rs1.Edit If Not IsNull(rs1("Betrag")) Then rs1("Betrag") = Runden(faktor * rs1("Betrag"), 3) End If rs1.Update rs1.MoveNext Wend rs1.Close Set rs1 = db1.OpenRecordset("SELECT * FROM TAuszahlungSortenQualitätsstufe WHERE AZNR=140") While Not rs1.EOF rs1.Edit If Not IsNull(rs1("Betrag")) Then rs1("Betrag") = Runden(faktor * rs1("Betrag"), 3) End If rs1.Update rs1.MoveNext Wend rs1.Close End Sub