Hans-Bärbel?! :)
Hier mal der Code (evtl. mag er etwas diletantisch sein, aber so VBA fitbin ich noch nicht) :
- Schon mal danke im voraus -
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1. Modul (hier wird einiges formatiert, wie könnte ich alles auf Standardformatierung ändern, also wie eine "jungfräuchliche" Mappe, die hat bei mir keine 12kB)
Sub OfferPreview()
' S T A R T
' Fehlermeldungen abschalten
Application.DisplayAlerts = False
Application.ScreenUpdating = False
' This Filename
Dim ThisFilename As String
Dim ThisFilenameArray As Variant
Dim ThisFilenameArrayLength As Integer
ThisFilename = ActiveWorkbook.FullName
ThisFilenameArray = Split(ThisFilename, "\")
ThisFilenameArrayLength = UBound(ThisFilenameArray)
ThisFilenameArrayLength = ThisFilenameArrayLength
ThisFilename = ThisFilenameArray(ThisFilenameArrayLength)
' Aktueller Name der Mappe zum späteren Rückschreiben
Dim XLSFile As String
XLSFile = ActiveWorkbook.FullName
' Aktueller Pfad der Mappe
Dim XLSPath As String
XLSPath = ActiveWorkbook.Path
' "Altes" Angebot aufräumen
Sheets("OFFER").Select
Range("A26:G65000").Select
'Selection.Font.ColorIndex = 1
'Selection.Font.Bold = False
Selection.ClearContents
' Zellen formatieren, damit Texte richtig dargestellt werden
Range("B26:C65500").Select
Selection.Value = Format("", "0,00")
Range("G26:G65500").Select
Selection.Value = Format("", "0,00")
' Fettschrift entfernen
Range("E26:E65500").Select
Selection.Font.Bold = False
' Typ des Angebots bestimmen
Dim OfferType As String
If Worksheets("CREATOR").OfferTypeBuyer = True Then
OfferType = "Buyer"
Else
OfferType = "Reseller"
End If
' Abhängig von gewählter Sprache -> Inhalte einfügen
Dim OfferLang As String
Dim Zwischensumme As String
Dim PreisNetto As String
Dim PreisBrutto As String
Dim Rabatt As String
If Worksheets("CREATOR").OfferLangGerman = True Then
' MsgBox ("de!")
Worksheets("OFFER").Cells(7, 1) = "Seiten:"
Worksheets("OFFER").Cells(9, 1) = "Datum:"
Worksheets("OFFER").Cells(10, 1) = "Von:"
Worksheets("OFFER").Cells(13, 1) = "An:"
Worksheets("OFFER").Cells(14, 1) = "z. Hd.:"
Worksheets("OFFER").Cells(16, 1) = "E-Mail"
Worksheets("OFFER").Cells(22, 7) = "Alle Preise in "
Worksheets("OFFER").Cells(24, 1) = "Pos."
Worksheets("OFFER").Cells(24, 2) = "Artikel"
Worksheets("OFFER").Cells(24, 3) = "Bezeichnung"
Worksheets("OFFER").Cells(24, 5) = "Einzelpreis"
Worksheets("OFFER").Cells(24, 6) = "Menge"
Worksheets("OFFER").Cells(24, 7) = "Gesamt"
OfferLang = "de"
Zwischensumme = "Zwischensumme"
PreisNetto = "Endpreis netto"
PreisBrutto = "Endpreis brutto"
Rabatt = "Rabatt in %"
Else
' MsgBox ("en!")
Worksheets("OFFER").Cells(7, 1) = "Pages:"
Worksheets("OFFER").Cells(9, 1) = "Date:"
Worksheets("OFFER").Cells(10, 1) = "From:"
Worksheets("OFFER").Cells(13, 1) = "To:"
Worksheets("OFFER").Cells(14, 1) = "Attn.:"
Worksheets("OFFER").Cells(16, 1) = "Email"
Worksheets("OFFER").Cells(22, 7) = "All prices in "
Worksheets("OFFER").Cells(24, 1) = "Pos."
Worksheets("OFFER").Cells(24, 2) = "Item"
Worksheets("OFFER").Cells(24, 3) = "Name"
Worksheets("OFFER").Cells(24, 5) = "Unit price"
Worksheets("OFFER").Cells(24, 6) = "Amount"
Worksheets("OFFER").Cells(24, 7) = "Total"
OfferLang = "en"
Zwischensumme = "Subtotal"
PreisNetto = "Price strictly net"
PreisBrutto = "Price gross"
Rabatt = "Rebate percentage"
End If
' Datum übertragen
Worksheets("OFFER").Cells(9, 3) = Worksheets("CREATOR").OfferDate.Value
' Absender in Zelle schreiben
Worksheets("OFFER").Cells(10, 3) = Worksheets("CREATOR").OfferMaker.Value
' Empfänger-Firma in Zelle schreiben
Worksheets("OFFER").Cells(13, 3) = Worksheets("CREATOR").OfferRecipientCompany.Value
' Empfänger-Name in Zelle schreiben
Worksheets("OFFER").Cells(14, 3) = Worksheets("CREATOR").OfferRecipientName.Value
' Empfänger-Email in die Zelle schreiben
Worksheets("OFFER").Cells(16, 3) = Worksheets("CREATOR").OfferRecipientEmail.Value
' Betreff einfügen und Zellhöhe anpassen
Dim OfferTopic As String
Dim OfferTopicArray As Variant
Dim OfferTopicArrayLeng
OfferTopic = Worksheets("CREATOR").OfferTopic.Value
Worksheets("OFFER").Cells(18, 3) = OfferTopic
' Zeilen zählen und Zellenhöhe anpassen
OfferTopicArray = Split(OfferTopic, Chr(10))
OfferTopicArrayLength = UBound(OfferTopicArray) + 1
Worksheets("OFFER").Rows("18").RowHeight = OfferTopicArrayLength * 17
Worksheets("OFFER").Cells(18, 3).Replace Chr(13), ""
' Anrede einfügen
Dim OfferAnrede As String
Dim OfferAnredeArray As Variant
Dim OfferAnredeArrayLength As Integer
OfferAnrede = Worksheets("CREATOR").OfferText.Value
Worksheets("OFFER").Cells(20, 1) = OfferAnrede
' Zeilen zählen und Zellenhöhe anpassen
OfferAnredeArray = Split(OfferAnrede, Chr(10))
OfferAnredeArrayLength = UBound(OfferAnredeArray) + 1
Worksheets("OFFER").Rows("20").RowHeight = OfferAnredeArrayLength * 15
Worksheets("OFFER").Cells(20, 1).Replace Chr(13), ""
' Produktliste vorbereiten
Dim OfferContent As String
Dim OfferProductTemp As String
Dim OfferAmountTemp As String
Dim OfferContentItemArray()
Dim OfferContentAmountArray()
Dim OfferPreparationArray As Variant
Dim OfferPreparationLength As Integer
Dim OfferPreparationContainer As Variant
Dim OfferPreparationProduct As String
Dim OfferPreparationAmount As String
OfferContent = Worksheets("CREATOR").OfferContent.Value
OfferPreparationArray = Split(OfferContent, Chr(10))
OfferPreparationLength = UBound(OfferPreparationArray)
' Arrays redimensionieren
ReDim OfferContentItemArray(OfferPreparationLength)
ReDim OfferContentAmountArray(OfferPreparationLength)
' Nachfolgende Absätze entfernen
'For i = 0 To OfferPreparationLength
' If OfferContentItemArray(i) = Chr(10) Then
' Shift (OfferContentItemArray(i))
' End If
'Next i
' Eingabe des Produktfeldes in zwei Arrays schreiben
For i = 0 To OfferPreparationLength
OfferPreparationContainer = Split(OfferPreparationArray(i), ">")
'Debug.Print OfferPreparationContainer(0) & "-> " & OfferPreparationContainer(1)
' Produktname in Array schreiben
OfferProductTemp = OfferPreparationContainer(0)
OfferContentItemArray(i) = OfferProductTemp
' Menge in Array schreiben
OfferAmountTemp = OfferPreparationContainer(1)
OfferContentAmountArray(i) = OfferAmountTemp
Next i
' Arrays testen
For i = 0 To UBound(OfferContentItemArray)
Debug.Print OfferContentItemArray(i)
Next i
For i = 0 To UBound(OfferContentAmountArray)
Debug.Print "-> " & OfferContentAmountArray(i)
Next i
'MsgBox "Items -> " & UBound(OfferContentItemArray)
'MsgBox "Amount -> " & UBound(OfferContentAmountArray)
' Produkte des Angebotes vorbereiten
Dim LastLine As Integer
Dim NeuerPreis As Double
Dim PosNumber As Integer
PosNumber = 1
' Letzte Zeile berechnen
Dim OfferLineStart As Integer
OfferLineStart = 26
Dim OfferLineEnd As Integer
OfferLineEnd = OfferLineStart + (UBound(OfferContentItemArray) * 2)
' Laufende Nummer erzeugen
Dim RunningNr As Integer
RunningNr = 0
' ANGEBOT GENERIEREN -> START
Dim LineNumber As Integer
Dim j As Integer
j = 0
For i = OfferLineStart To OfferLineEnd Step 2
' Zeile des Produktes suchen
Dim ProductName As String
ProductName = OfferContentItemArray(j)
ProductName = Left(ProductName, Len(ProductName) - 1)
' Artikelnummer suchen
LineNumber = Workbooks("Preisliste.xls").Sheets("ndt1").Range("A1:A1000").Find(ProductName).Row
' j erhöhen für den nächsten Durchgang
j = j + 1
Workbooks(ThisFilename).Activate
' Positionsnummer einfügen
Worksheets("OFFER").Cells(i, 1) = PosNumber
Worksheets("OFFER").Cells(i, 1).Replace " ", ""
PosNumber = PosNumber + 1
' Artikelnummer schreiben
Worksheets("OFFER").Cells(i, 2).Formula = _
"='" & XLSPath & "\DATA\" & "[" & "Preisliste.xls" & "]" & "ndt1" & "'!" & "A" & LineNumber
Trim (Worksheets("OFFER").Cells(i, 2))
' Bezeichnung schreiben
' Deutsch ?
If OfferLang = "de" Then
Worksheets("OFFER").Cells(i, 3).Formula = _
"='" & XLSPath & "\DATA\" & "[" & "Preisliste.xls" & "]" & "ndt1" & "'!" & "B" & LineNumber
Trim (Worksheets("OFFER").Cells(i, 3))
' Englisch ?
Else
Worksheets("OFFER").Cells(i, 3).Formula = _
"='" & XLSPath & "\DATA\" & "[" & "Preisliste.xls" & "]" & "ndt1" & "'!" & "C" & LineNumber
Trim (Worksheets("OFFER").Cells(i, 3))
End If
' Preis schreiben
Dim Preis As Long
' Endkunde ?
If OfferType = "Buyer" Then
Worksheets("OFFER").Cells(i, 5).Formula = _
"='" & XLSPath & "\DATA\" & "[" & "Preisliste.xls" & "]" & "ndt1" & "'!" & "D" & LineNumber
Trim (Worksheets("OFFER").Cells(i, 5))
' Reseller ?
Else
Worksheets("OFFER").Cells(i, 5).Formula = _
"='" & XLSPath & "\DATA\" & "[" & "Preisliste.xls" & "]" & "ndt1" & "'!" & "E" & LineNumber
Trim (Worksheets("OFFER").Cells(i, 5))
End If
' Menge schreiben
Dim Menge As Integer
Menge = PosNumber
Worksheets("OFFER").Cells(i, 6) = OfferContentAmountArray(RunningNr)
Worksheets("OFFER").Cells(i, 6).Replace Chr(10), ""
Worksheets("OFFER").Cells(i, 6).Replace Chr(13), ""
Worksheets("OFFER").Cells(i, 6).Value = Format(Worksheets("OFFER").Cells(i, 6), "0,00")
Trim (Worksheets("OFFER").Cells(i, 6))
RunningNr = RunningNr + 1
' Gesamtpreis ausrechnen
'Worksheets("OFFER").Cells(i, 7) = (Worksheets("OFFER").Cells(i, 5) * 1) * Worksheets("OFFER").Cells(i, 6)
Worksheets("OFFER").Cells(i, 7).Formula = _
"=E" & i & "*F" & i
Trim (Worksheets("OFFER").Cells(i, 7))
' Neuer Preis
NeuerPreis = NeuerPreis + Worksheets("OFFER").Cells(i, 7)
' Letzte Zeile in Variable sichern
LastLine = i
Next i
' ANGEBOT GENERIEREN -> ENDE
' Zwischensumme ausgeben
LastLine = LastLine + 2
Worksheets("OFFER").Cells(LastLine, 5) = Zwischensumme
Worksheets("OFFER").Cells(LastLine, 5).Font.Bold = True
' Rechtbündig
'Worksheets("OFFER").Cells(LastLine, 7).Formula = _
'"=SUMME(G26:G" & LastLine - 2 & ")"
Worksheets("OFFER").Cells(LastLine, 7) = NeuerPreis
' Rabatt einfügen ?
LastLine = LastLine + 2
Worksheets("OFFER").Cells(LastLine, 5) = Rabatt
Worksheets("OFFER").Cells(LastLine, 5).Font.Bold = True
Dim OfferRebate As Double
OfferRebate = Worksheets("CREATOR").OfferRebate.Value
Worksheets("OFFER").Cells(LastLine, 7) = OfferRebate
' Netto-Preis
LastLine = LastLine + 2
Worksheets("OFFER").Cells(LastLine, 5) = PreisNetto
Worksheets("OFFER").Cells(LastLine, 5).Font.Bold = True
Dim NettoPreis As Double
NettoPreis = NeuerPreis - (NeuerPreis * (OfferRebate / 100))
Worksheets("OFFER").Cells(LastLine, 7) = NettoPreis
' Brutto-Preis
Dim BruttoPreis As Double
Dim OfferTax As Integer
OfferTax = Worksheets("CREATOR").OfferTax.Value
BruttoPreis = NettoPreis * ((OfferTax / 100) + 1)
LastLine = LastLine + 2
Worksheets("OFFER").Cells(LastLine, 5) = PreisBrutto
Worksheets("OFFER").Cells(LastLine, 5).Font.Bold = True
Worksheets("OFFER").Cells(LastLine, 7) = BruttoPreis
' Die Zahl der Druckseiten berechnen
Dim CountPages As Integer
' Aktive Tabelle wechseln
Sheets("OFFER").Select
CountPages = ExecuteExcel4Macro("Get.Document(50)")
Worksheets("OFFER").Cells(7, 3) = CountPages
Worksheets("OFFER").Cells(7, 3).Font.ColorIndex = 1
Worksheets("OFFER").Cells(7, 3).Font.Bold = True
' Aktive Tabelle wechseln
Sheets("CREATOR").Select
Application.ScreenUpdating = True
' Druckvorschau öffnen
Worksheets("OFFER").PrintPreview
' E N D E
End Sub
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2. Modul
Sub OfferResave()
' This Filename
Dim ThisFilename As String
ThisFilename = ActiveWorkbook.FullName
' Alte Datei überschreiben
ActiveWorkbook.SaveAs ThisFilename
End Sub
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3. Modul
Sub OfferSaveAs()
' New Filename
Dim NewFilename As Integer
Dim NextFilename As Integer
NewFilename = Worksheets("CREATOR").Cells(4, 2)
NextFilename = NewFilename + 1
Worksheets("CREATOR").Cells(4, 2) = NextFilename
' Kopie der Mappe speichern
Dim XLSPath As String
Dim XLSFile As String
XLSFile = ActiveWorkbook.FullName
XLSPath = ActiveWorkbook.Path
' Benutzernamen auslesen
Dim UserName As String
UserName = Application.UserName
Dim OfferDate As String
OfferDate = Worksheets("CREATOR").OfferDate.Value
Dim OfferRecipientCompany As String
OfferRecipientCompany = Worksheets("CREATOR").OfferRecipientCompany.Value
' Neue Mappe schreiben
ActiveWorkbook.SaveAs XLSPath & "\ANGEBOTE\" & NewFilename & "_" & UserName & "_" & OfferDate & "_" & OfferRecipientCompany & ".xls"
' Zurückspeichern
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs XLSFile
Application.DisplayAlerts = True
End Sub
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4. Modul
Sub OfferPrint()
' Angebot drucken
Worksheets("OFFER").PrintOut
End Sub
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Das wäre es.... vielen dank für Deine Zeit.
Gruß
kk3003