Thema Datum  Von Nutzer Rating
Antwort
Rot sub funktion
21.03.2016 10:25:23 Marcus
NotSolved
21.03.2016 15:46:11 Holger
NotSolved

Ansicht des Beitrags:
Von:
Marcus
Datum:
21.03.2016 10:25:23
Views:
570
Rating: Antwort:
  Ja
Thema:
sub funktion
Hi, ich habe jetzt folgendes Makro geschrieben, was durchaus seine function erfüllt. jedoch würde ich gerne jede Quelle lieber über ein sub bearbeiten. komischerweise become ich das partout nicht hin. hat hier jemand einen tipp? << Sub Rechnung() Dim ABC, A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P, Q, R, S, T, U, V, W, X, Y, Z As Integer 'Zaehler Dim Quelle1, Quelle2, Quelle3, Quelle4, Quelle5, Quelle6, Quelle7, Quelle8, Quelle9 As String 'Konstante fuer Worksheet 1 Dim Ziel, fallig, zahlein As String 'Konstante fuer Ziel Worksheet Dim currentDate, datum As Date '========================================== 'Definition der Sheets welche durchforstet werden Quelle1 = "A1" Quelle2 = "A2" Quelle3 = "A3" Quelle4 = "A4" Quelle5 = "A5" Quelle6 = "A6" Quelle7 = "" Quelle8 = "" Quelle9 = "" Ziel = "Forderungsübersicht" '========================================= ' Rows("2:801").delete 'Variable für Zeile "Z"; Beschriftung startet in Zeile 3 Z = 2 '===========================================================================================Quelle1 For A = 1 To 150 C = Worksheets(Quelle1).Cells(A, 13).Value D = Left(C, 1) If D = "5" Then Worksheets(Ziel).Cells(Z, 2).Value = Worksheets(Quelle1).Cells(A, 13).Value 'Rechnungsnummer Worksheets(Ziel).Cells(Z, 3).Value = Worksheets(Quelle1).Cells(A, 2).Value 'Shipment If Worksheets(Quelle1).Cells(A, 16).Value = "Delivery Payment" Then Worksheets(Ziel).Cells(Z, 4).Value = Worksheets(Quelle1).Cells(A, 8).Value ElseIf Worksheets(Quelle1).Cells(A, 16).Value = "Final Payment" Then Worksheets(Ziel).Cells(Z, 4).Value = Worksheets(Quelle1).Cells(A, 6).Value End If Worksheets(Ziel).Cells(Z, 5).Value = Worksheets(Quelle1).Cells(A, 4).Value 'Rechnungsdatum Worksheets(Ziel).Cells(Z, 6).Value = Worksheets(Quelle1).Cells(A, 12).Value 'Fälligkeitsdatum Worksheets(Ziel).Cells(Z, 7).Value = Worksheets(Quelle1).Cells(A, 11).Value 'Zahlungseingang Worksheets(Ziel).Cells(Z, 8).Value = Worksheets(Quelle1).Cells(A, 16).Value Z = Z + 1 End If Next A '===========================================================================================Quelle2 For A = 1 To 150 C = Worksheets(Quelle2).Cells(A, 13).Value D = Left(C, 1) If D = "5" Then Worksheets(Ziel).Cells(Z, 2).Value = Worksheets(Quelle2).Cells(A, 13).Value 'Rechnungsnummer Worksheets(Ziel).Cells(Z, 3).Value = Worksheets(Quelle2).Cells(A, 2).Value 'Shipment If Worksheets(Quelle2).Cells(A, 17).Value = "Delivery Payment" Then Worksheets(Ziel).Cells(Z, 4).Value = Worksheets(Quelle2).Cells(A, 8).Value ElseIf Worksheets(Quelle2).Cells(A, 17).Value = "Final Payment" Then Worksheets(Ziel).Cells(Z, 4).Value = Worksheets(Quelle2).Cells(A, 6).Value End If Worksheets(Ziel).Cells(Z, 5).Value = Worksheets(Quelle2).Cells(A, 4).Value 'Rechnungsdatum Worksheets(Ziel).Cells(Z, 6).Value = Worksheets(Quelle2).Cells(A, 12).Value 'Fälligkeitsdatum Worksheets(Ziel).Cells(Z, 7).Value = Worksheets(Quelle2).Cells(A, 11).Value 'Zahlungseingang Worksheets(Ziel).Cells(Z, 8).Value = Worksheets(Quelle2).Cells(A, 17).Value Z = Z + 1 End If Next A '==============================================================================================Quelle3 For A = 1 To 150 C = Worksheets(Quelle3).Cells(A, 13).Value D = Left(C, 1) If D = "5" Then Worksheets(Ziel).Cells(Z, 2).Value = Worksheets(Quelle3).Cells(A, 13).Value 'Rechnungsnummer Worksheets(Ziel).Cells(Z, 3).Value = Worksheets(Quelle3).Cells(A, 2).Value 'Shipment If Worksheets(Quelle3).Cells(A, 17).Value = "Delivery Payment" Then Worksheets(Ziel).Cells(Z, 4).Value = Worksheets(Quelle3).Cells(A, 8).Value ElseIf Worksheets(Quelle3).Cells(A, 17).Value = "Final Payment" Then Worksheets(Ziel).Cells(Z, 4).Value = Worksheets(Quelle3).Cells(A, 6).Value End If Worksheets(Ziel).Cells(Z, 5).Value = Worksheets(Quelle3).Cells(A, 4).Value 'Rechnungsdatum Worksheets(Ziel).Cells(Z, 6).Value = Worksheets(Quelle3).Cells(A, 12).Value 'Fälligkeitsdatum Worksheets(Ziel).Cells(Z, 7).Value = Worksheets(Quelle3).Cells(A, 11).Value 'Zahlungseingang Worksheets(Ziel).Cells(Z, 8).Value = Worksheets(Quelle3).Cells(A, 17).Value Z = Z + 1 End If Next A '===========================================================================================Quelle4 For A = 1 To 150 C = Worksheets(Quelle4).Cells(A, 13).Value D = Left(C, 1) If D = "5" Then Worksheets(Ziel).Cells(Z, 2).Value = Worksheets(Quelle4).Cells(A, 13).Value 'Rechnungsnummer Worksheets(Ziel).Cells(Z, 3).Value = Worksheets(Quelle4).Cells(A, 2).Value 'Shipment If Worksheets(Quelle4).Cells(A, 17).Value = "Delivery Payment" Then Worksheets(Ziel).Cells(Z, 4).Value = Worksheets(Quelle4).Cells(A, 8).Value ElseIf Worksheets(Quelle4).Cells(A, 17).Value = "Final Payment" Then Worksheets(Ziel).Cells(Z, 4).Value = Worksheets(Quelle4).Cells(A, 6).Value End If Worksheets(Ziel).Cells(Z, 5).Value = Worksheets(Quelle4).Cells(A, 4).Value 'Rechnungsdatum Worksheets(Ziel).Cells(Z, 6).Value = Worksheets(Quelle4).Cells(A, 12).Value 'Fälligkeitsdatum Worksheets(Ziel).Cells(Z, 7).Value = Worksheets(Quelle4).Cells(A, 11).Value 'Zahlungseingang Worksheets(Ziel).Cells(Z, 8).Value = Worksheets(Quelle4).Cells(A, 17).Value Z = Z + 1 End If Next A '===========================================================================================Quelle5 For A = 1 To 150 C = Worksheets(Quelle5).Cells(A, 13).Value D = Left(C, 1) If D = "5" Then Worksheets(Ziel).Cells(Z, 2).Value = Worksheets(Quelle5).Cells(A, 13).Value 'Rechnungsnummer Worksheets(Ziel).Cells(Z, 3).Value = Worksheets(Quelle5).Cells(A, 2).Value 'Shipment If Worksheets(Quelle5).Cells(A, 17).Value = "Delivery Payment" Then Worksheets(Ziel).Cells(Z, 4).Value = Worksheets(Quelle5).Cells(A, 8).Value ElseIf Worksheets(Quelle5).Cells(A, 17).Value = "Final Payment" Then Worksheets(Ziel).Cells(Z, 4).Value = Worksheets(Quelle5).Cells(A, 6).Value End If Worksheets(Ziel).Cells(Z, 5).Value = Worksheets(Quelle5).Cells(A, 4).Value 'Rechnungsdatum Worksheets(Ziel).Cells(Z, 6).Value = Worksheets(Quelle5).Cells(A, 12).Value 'Fälligkeitsdatum Worksheets(Ziel).Cells(Z, 7).Value = Worksheets(Quelle5).Cells(A, 11).Value 'Zahlungseingang Worksheets(Ziel).Cells(Z, 8).Value = Worksheets(Quelle5).Cells(A, 17).Value Z = Z + 1 End If Next A '===========================================================================================Quelle6 For A = 1 To 150 C = Worksheets(Quelle6).Cells(A, 13).Value D = Left(C, 1) If D = "5" Then Worksheets(Ziel).Cells(Z, 2).Value = Worksheets(Quelle6).Cells(A, 13).Value 'Rechnungsnummer Worksheets(Ziel).Cells(Z, 3).Value = Worksheets(Quelle6).Cells(A, 2).Value 'Shipment If Worksheets(Quelle6).Cells(A, 17).Value = "Delivery Payment" Then Worksheets(Ziel).Cells(Z, 4).Value = Worksheets(Quelle6).Cells(A, 8).Value ElseIf Worksheets(Quelle6).Cells(A, 17).Value = "Final Payment" Then Worksheets(Ziel).Cells(Z, 4).Value = Worksheets(Quelle6).Cells(A, 6).Value End If Worksheets(Ziel).Cells(Z, 5).Value = Worksheets(Quelle6).Cells(A, 4).Value 'Rechnungsdatum Worksheets(Ziel).Cells(Z, 6).Value = Worksheets(Quelle6).Cells(A, 12).Value 'Fälligkeitsdatum Worksheets(Ziel).Cells(Z, 7).Value = Worksheets(Quelle6).Cells(A, 11).Value 'Zahlungseingang Worksheets(Ziel).Cells(Z, 8).Value = Worksheets(Quelle6).Cells(A, 17).Value Z = Z + 1 End If Next A '=======================================================Datum & Betrag Check! 'P werden die Summe von allen offenen Beträgen 'Q wird die Summe von allen offenen und fälligen Beträgen P = 0 Q = 0 For D = 2 To Z datum = Worksheets(Ziel).Cells(D, 6).Value fallig = Worksheets(Ziel).Cells(D, 6).Value zahlein = Worksheets(Ziel).Cells(D, 7).Value Cells(D, 2).HorizontalAlignment = xlCenter 'Zentriert die 500xxx Nummer Cells(D, 3).HorizontalAlignment = xlCenter 'Zentriert die Shipment Cells(D, 4).Style = "Currency" ' Formatiert die Zahl wie gewünscht If datum <= Date And zahlein = "" And fallig <> "" Then Q = Q + Worksheets(Ziel).Cells(D, 4).Value Cells(D, 6).Interior.Color = RGB(226, 166, 200) 'farbe in RGB format suchen und anpassen bei bedarf Cells(D, 6).Font.Bold = True 'macht im falle dass die Zahlung fällig ist die schrift das datums fett If fallig <> "" Then Worksheets(Ziel).Cells(D, 9).Value = Date - datum Cells(D, 9).Font.Bold = True 'macht im falle dass die Zahlung fällig ist die schrift die anzahl der tage seitdem es überfällig ist fett Worksheets(Ziel).Cells(D, 10).Value = "Tagen" Cells(D, 10).Font.Bold = True 'macht im falle dass die Zahlung fällig ist die schrift des wortes "Tagen" fett End If ElseIf Worksheets(Ziel).Cells(D, 4).Value <> "" And zahlein = "" Then P = Worksheets(Ziel).Cells(D, 4).Value + P End If Next D P = P + Q Worksheets(Ziel).Cells(3, 12).Value = Q Worksheets(Ziel).Cells(4, 12).Value = P Worksheets(Ziel).Cells(3, 11).Value = "Summe offene und fällige Beträge" 'einfach nur eine zellenbeschriftung Worksheets(Ziel).Cells(4, 11).Value = "Summe offene Beträge" 'einfach nur eine zellenbeschriftung Worksheets(Ziel).Cells(3, 12).Style = "Currency" 'formatiert die Zahl entsprechend nach currency um Worksheets(Ziel).Cells(4, 12).Style = "Currency" 'formatiert die Zahl entsprechend nach currency um Range(Cells(3, 11), Cells(4, 12)).Borders.LineStyle = xlcontinous 'alle zellen im angabe bereich werden mit durchgehenden trennlinien versehen Range(Cells(3, 11), Cells(4, 12)).Borders.Weight = xlThin 'alle zellen im angabe bereich werden mit dünnen trennlinien versehen Range(Cells(3, 11), Cells(4, 12)).BorderAround _ Weight:=xlThick 'alle 4 Zellen werden mit einem dicken rahmen versehen Range(Cells(3, 11), Cells(4, 12)).Interior.Color = RGB(226, 166, 200) 'der betroffene bereich wird entsprechend farblich eingefärbt Range(Cells(3, 11), Cells(4, 12)).Font.Bold = True 'der betroffene Bereich wird auf "fett" formatiert End Sub>>

Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst genau und ausführlich
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
  • Bitte markieren Sie Ihre Anfrage als erledigt wenn Ihnen geholfen wurde
Thema: Name: Email:

 
 

Thema Datum  Von Nutzer Rating
Antwort
Rot sub funktion
21.03.2016 10:25:23 Marcus
NotSolved
21.03.2016 15:46:11 Holger
NotSolved