Thema: Stückelung nach EURO

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