VBA-Programmierung in Microsoft Excel

Tutorial: Excel-Beispiele

Stückelung nach EURO

Gruppe

Funktion

Bereich

SUMMENPRODUKT

Thema

Stückelung nach EURO

Problem

Der Betrag in Zelle A3 soll gemäß den in Euro zur Verfügung stehenden Noten und Münzen gestückelt werden.

Lösung

Nur anhand einer Beipspielarbeitsmappe darstellbar.




ClassModule: frmCode

Private Sub cboLaender_Change()
   If txtCode.TextLength = 11 Then
      Call txtCode_Change
   End If
End Sub

Private Sub cmdCancel_Click()
   Unload Me
End Sub

Private Sub cmdOK_Click()
   ActiveCell.Value = lblCode.Caption
   Unload Me
End Sub

Private Sub txtCode_Change()
   Dim wks As Worksheet
   Dim iChar As Integer, iCode As Integer
   Dim sCode As String, sTmp As String
   If txtCode.TextLength = 0 Then
      lblCode.Caption = ""
      Exit Sub
   End If
   If Right(txtCode.Text, 1) Like "[0-9]" = False Then
      txtCode.Text = Left(txtCode.Text, Len(txtCode.Text) - 1)
   End If
   Set wks = ThisWorkbook.Worksheets("Länder")
   If txtCode.TextLength = 11 Then
      sCode = wks.Cells(cboLaender.ListIndex + 1, 3).Value
      sCode = sCode & txtCode.Text
      For iChar = 14 To 1 Step -2
         iCode = iCode + CInt(Mid(sCode, iChar, 1))
      Next iChar
      iCode = iCode * 3
      For iChar = 13 To 1 Step -2
         iCode = iCode + CInt(Mid(sCode, iChar, 1))
      Next iChar
      iCode = Fix(iCode / 10) * 10 + 10 - iCode
      sTmp = wks.Cells(cboLaender.ListIndex + 1, 2).Value & _
         " " & Mid(sCode, 4, 3) & "." & _
         Mid(sCode, 7, 4) & "." & _
         Mid(sCode, 11, 4) & "." & iCode
      If Right(sTmp, 2) = "10" Then
         sTmp = Left(sTmp, Len(sTmp) - 2) & "0"
      End If
      iCode = InStr(sTmp, " ") + 1
      Do Until Mid(sTmp, iCode, 1) <> "0"
         Mid(sTmp, iCode, 1) = "µ"
         iCode = iCode + 1
      Loop
      sTmp = WorksheetFunction.Substitute(sTmp, "µ", "")
      lblCode.Caption = sTmp
      cmdOK.SetFocus
   End If
End Sub

Private Sub UserForm_Initialize()
   cboLaender.List = ThisWorkbook.Worksheets("Länder") _
      .Range("A1").CurrentRegion.Columns(1).Value
   cboLaender.ListIndex = 0
End Sub

StandardModule: Modul1

Sub DialogAufruf()
   frmCode.Show
End Sub

    


Beiträge aus dem Excel-Forum zu den Themen Funktion und SUMMENPRODUKT