VBA Funktionen

14/04/2010 - 16:10 von Ecksel2003 | Report spam
Hallo,
ich veröffentliche mal ein paar eigene Funktionen. Vielleicht helfen sie
jemandem.

-

' Konvertiert Positive Zahlen mit Kennzeichen S in negative Zahlen z.B. von
Kontoauszugsdaten
Public Function Voba(Betrag As Double, KZ As String) As Double

If KZ = "S" Then
Multiplikator = -1
Else
Multiplikator = 1
End If

Voba = Betrag * Multiplikator

End Function

-

Function QVerweis(DataRange As Range, MasterRange As Range, Offset As
Integer) As String

' Die Funktion QVerweis funktioniert àhnlich wie SVerweis
' Der Unterschied ist, dass QVerweis nicht einen bestimmten Suchtext
verwendet und
' in einer Tabelle nach der Entsprechung sucht.
' Der Suchtext von QVerweis ist in einem Bereich (DataRange) enthalten.
' Er kann auch nur ein Teil einer Zeichenfolge sein.
' Der Rest ist wie in SVerweis. MasterRange ist die Tabelle, deren linke
Spalte den Suchtext enthalten kann.
' Sofern das der Fall ist, wird mit dem Offset ein Wert aus einer Spalte
rechts wiedergegeben.


Application.Volatile ' Rechnet immer und nicht nur auf Befehl

' Data Tabelle
Dim DataFile As Worksheet
Dim DLeftColumn As Integer
Dim DRightColumn As Integer
Dim DTopRow As Integer
Dim DLowRow As Integer
Dim DataContent As Range

Set DataFile = DataRange.Parent ' Parent ist das übergeordnete Objekt
(von einem Zellbereich ist das daher das Blatt)
DLeftColumn = DataRange.Column
DRightColumn = DataRange.Columns.Count + DLeftColumn - 1
DTopRow = DataRange.Row
DLowRow = DataRange.Rows.Count + DTopRow - 1
If DTopRow = DLowRow Then
Else
QVerweis = "#Fehler: Der Suchbereich darf nur eine Zeile umfassen."
GoTo EndOfFunction
End If

'Master Tabelle
Dim MasterFile As Worksheet
Dim LastMaster As Integer
Dim MLeftColum As Integer
Dim MRightColumn As Integer
Dim MTopRow As Integer
Dim MLowRow As Integer
Dim MasterSearch As String

Set MasterFile = MasterRange.Parent ' Parent ist das übergeordnete Objekt
(von einem Zellbereich ist das daher das Blatt)
MLeftColumn = MasterRange.Column
MRightColumn = MasterRange.Columns.Count + MLeftColumn - 1
MTopRow = MasterRange.Row
MLowRow = MasterRange.Rows.Count + MTopRow - 1
If MLeftColumn = MRightColumn Then
QVerweis = "#Fehler: Der Masterbereich muß mindestens zwei Spalten
umfassen."
GoTo EndOfFunction
Else
End If
LastMaster = MasterFile.Range(MasterFile.Cells(MTopRow, MLeftColumn),
MasterFile.Cells(MLowRow, MRightColumn)).Find(What:="*",
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ' merkt sich die
letzte Zeile aus dem Master-KA IST OK

' Beginn der Suche
For MasterLine = MTopRow To LastMaster
MasterSearch = MasterFile.Range(MasterFile.Cells(MasterLine,
MLeftColumn), MasterFile.Cells(MasterLine, MLeftColumn)).Value
Set DataContent = DataFile.Range(DataFile.Cells(DTopRow, DLeftColumn),
DataFile.Cells(DLowRow, DRightColumn)).Find(MasterSearch, LookAt:=xlPart)
If Not DataContent Is Nothing Then
Ergebnis = MasterFile.Range(MasterFile.Cells(MasterLine,
MLeftColumn + Offset - 1), MasterFile.Cells(MasterLine, MLeftColumn + Offset
- 1)).Value
FindCount = FindCount + 1
If FindCount = 1 Then
FindMultiple = Ergebnis
Else
FindMultiple = FindMultiple & ", " & Ergebnis
End If
End If

Next MasterLine

If FindCount = 1 Then
QVerweis = Ergebnis
Else
If FindCount = 0 Then
QVerweis = ""
Else
QVerweis = "#Fehler: Multiple Vorkommnisse: (" & FindMultiple & ")"
End If
End If

EndOfFunction:
End Function



' Errechnet das Alter
Public Function Alter(Geburtsdatum, AktuellesDatum As String) As Date

If ((Month(Geburtsdatum) * 100 + Day(Geburtsdatum)) > (Month(AktuellesDatum)
* 100 + Day(AktuellesDatum))) Then Alter = Year(AktuellesDatum) -
Year(Geburtsdatum) - 1
If ((Month(Geburtsdatum) * 100 + Day(Geburtsdatum)) <=
(Month(AktuellesDatum) * 100 + Day(AktuellesDatum))) Then Alter =
Year(AktuellesDatum) - Year(Geburtsdatum)
End Function

-

' HFM Funktion - Ermittelt die Bezeichung von mehreren Hyperion Parametern
Public Function HsBez(HFM As String) As String
If InStr(1, HFM, "Entity") > 0 Then HsBez = HsBez &
Application.Run("HsTbar.xla!HsDescription", Mid(HFM, InStr(1, HFM, "Entity"),
11)) & " - "
If InStr(1, HFM, "Account") > 0 Then HsBez = HsBez &
Application.Run("HsTbar.xla!HsDescription", Mid(HFM, InStr(1, HFM,
"Account"), 15)) & " - "
If InStr(1, HFM, "Custom1") > 0 Then
If InStr(1, HFM, "Custom1#TotalCustom1") = 0 Then
HsBez = HsBez & Application.Run("HsTbar.xla!HsDescription", Mid(HFM,
InStr(1, HFM, "Custom1"), 13)) & " - "
End If
End If
If InStr(1, HFM, "Custom2") > 0 Then
If InStr(1, HFM, "Custom2#TotalCustom2") = 0 Then
HsBez = HsBez & Application.Run("HsTbar.xla!HsDescription", Mid(HFM,
InStr(1, HFM, "Custom2"), 13)) & " - "
End If
End If
If Right(HsBez, 2) = "- " Then HsBez = Left(HsBez, Len(HsBez) - 3)
End Function
 

Lesen sie die antworten

#1 Alexander Wolff
14/04/2010 - 18:32 | Warnen spam
Hallo Ecksel,

das ist grundsàtzlich nett von Dir. Es wirkt jedoch ein wenig so, als seien
dies die gesammelten Werke DEINER Belange. Ungefragt macht das in einer
Newsgroup wenig Sinn.

Newsgroups werden übrigens von Google archiviert. D.h., auch Deine
Funktionen wird man jetzt auf vorlàufig ewig dort finden. Wird man das?
Voba? Ich vermute, das heißt Volksbank. Was stellt man sich denn unter einer
Funktion Voba vor?

Immerhin hast Du den Zweck der Funktion noch dargelegt. Dann hàttest Du aber
auch gleich die Funktion umbenennen können in "VorzeichenwechselBeiS_KZ",
z.B.

Bei "Hyperion" wird das schon schlechter. Ich habe mal gegoogelt und
vermute, dass Du "Oracle Hyperion" meinst. Aber muss das jeder einfach so
wissen?

Auch sinnvoll ist, wenn Du schon so uneigennützig bist, vielleicht das
Führen einer eigenen Webseite, wo Du dies unterbringst.
Moin+Gruss Alexander - MVP for MS Excel - www.xxcl.de - mso2000sp3 --7-2

Ähnliche fragen