Custom Function to find value and offset

[silentwolf]

Hi guys,
I am in need for help.(
I would like to write a custom function which findes certain values and offset once it is found two columns to the right.

function Test(strText as string) as string
Select Case True
Case strText = "Good"
?? offset found cell one column to the right get and modify that cell
Case strText="Bad"
?? offset found cell one column to the right get and modify that cell
Case strText ="Worst"
?? offset found cell one column to the right get and modify that cell
Case else

End select
end function

That is what I like to have but I am not able to get it to work...

Many thanks for your helb

Greetings

Albert

 

[Norie]

It's my fault - too early in the morning here.

Try this.

For LoopCounter = 1 To 9
     Guthaben(LoopCounter, GuthabenCounter) = r.Offset(0, LoopCounter - 1).Value
Next LoopCounter

Guthaben(10, GuthabenCounter) = BezahlteRechnungen(Guthaben(9, GuthabenCounter))

 

[silentwolf]

I am not getting an error but it is not dooing anything.. here is my complete code.. with the function...

Sub LastSchrifenGleicheSpalteBerechnen()
    Dim Guthaben() As Variant
    Dim r As Range
    Dim GuthabenCounter As Long
    Dim LoopCounter As Long
    
    For Each r In Range("A2", Range("A1").End(xlDown))
        If r.Offset(0, 8).Value = "SEPA-Lastschrift" Then
            GuthabenCounter = GuthabenCounter + 1
            
            ReDim Preserve Guthaben(1 To 10, 1 To GuthabenCounter)
            
            For LoopCounter = 1 To 10
                Guthaben(LoopCounter, GuthabenCounter) = r.Offset(0, LoopCounter - 1).Value
            Next LoopCounter
        End If
    Next r
    
    Guthaben(10, GuthabenCounter) = LastschriftenTextUpdate(Guthaben(9, GuthabenCounter))

End Sub

Function LastschriftenTextUpdate(ByVal strText As String) As String
    Dim intPos As Integer
    
    Select Case True
        Case strText Like "*Aktiengesellschaft *"
            intPos = InStr(strText, "Aktiengesellschaft")
            LastschriftenTextUpdate = Left(strText, intPos + 17)
            
        Case strText Like "*AG *"
            intPos = InStr(strText, "AG")
            LastschriftenTextUpdate = Left(strText, intPos + 2)
    
        Case strText Like "*GmbH *"
            intPos = InStr(strText, "GmbH")
            LastschriftenTextUpdate = Left(strText, intPos + 3)
    
        Case strText Like "*GMBH *"
            intPos = InStr(strText, "GMBH")
            LastschriftenTextUpdate = Left(strText, intPos + 3)
    
        Case strText Like "*Finanzierung*"
            intPos = InStr(strText, "Finanzierung")
            LastschriftenTextUpdate = Left(strText, intPos + 11)
    Case Else
            LastschriftenTextUpdate = strText
    End Select
End Function

Do I have to change the sub where this line Guthaben(10, GuthabenCounter) = BezahlteRechnungen(Guthaben(9, GuthabenCounter)is ?

 

[Norie]

Have you stepped through the function?

 

[silentwolf]

Yes Norie I did the function works ..
but if I step trough the sub it findes in this case "SEPA-Lastschrift" and loops through the array but it does not got to the line after the Next r...
So does the
Guthaben(10, GuthabenCounter)=LastschriftenTextUpdate(Guthaben(9, GuthabenCounter))
need to be in a different location of the sub?
before it goes to the Next r??


So it goes through the loop of the sub but not get to the function ... is what I am trying to say it works seperatelly but not together (

 

[Norie]

This needs to go after the 2nd loop.

 Guthaben(10, GuthabenCounter) = LastschriftenTextUpdate(Guthaben(9, GuthabenCounter))

The whole code.

Sub LastSchrifenGleicheSpalteBerechnen()
Dim Guthaben() As Variant
Dim r As Range
Dim GuthabenCounter As Long
Dim LoopCounter As Long

    For Each r In Range("A2", Range("A1").End(xlDown))
        If r.Offset(0, 8).Value = "SEPA-Lastschrift" Then
            GuthabenCounter = GuthabenCounter + 1

            ReDim Preserve Guthaben(1 To 10, 1 To GuthabenCounter)

            For LoopCounter = 1 To 9
                Guthaben(LoopCounter, GuthabenCounter) = r.Offset(0, LoopCounter - 1).Value
            Next LoopCounter

            Guthaben(10, GuthabenCounter) = LastschriftenTextUpdate(Guthaben(9, GuthabenCounter))

        End If
    Next r

End Sub

Function LastschriftenTextUpdate(ByVal strText As String) As String

    Select Case True
    
        Case strText Like "*Aktiengesellschaft *"
            intPos = InStr(strText, "Aktiengesellschaft")
            LastschriftenTextUpdate = Left(strText, intPos + 17)

        Case strText Like "*AG *"
            intPos = InStr(strText, "AG")
            LastschriftenTextUpdate = Left(strText, intPos + 2)

        Case strText Like "*GmbH *"
            intPos = InStr(strText, "GmbH")
            LastschriftenTextUpdate = Left(strText, intPos + 3)

        Case strText Like "*GMBH *"
            intPos = InStr(strText, "GMBH")
            LastschriftenTextUpdate = Left(strText, intPos + 3)

        Case strText Like "*Finanzierung*"
            intPos = InStr(strText, "Finanzierung")
            LastschriftenTextUpdate = Left(strText, intPos + 11)
            
        Case Else
            LastschriftenTextUpdate = strText
            
    End Select
    
End Function

 

[silentwolf]

IBAN	Auszugsnummer	Buchungsdatum	Valutadatum	Umsatzzeit	Zahlungsreferenz	Waehrung	Betrag	Buchungstext	Umsatztext
AT2	9	30.12.2016	30.12.2016	2016-12-29-19.48.27.460659		EUR	0	SEPA-Gutschrift	Hubl Dr. Harald 6000 Schwendt, Irgendwas 3 Zahlungsreferenz:
AT3	1	04.01.2016	04.01.2016	2016-01-04-12.40.46.80754		EUR	-100	SEPA-Lastschrift	XB Leasing Finanzierung Straße 22 - 29 Wien
AT4	1	04.01.2016	04.01.2016	2016-01-04-12.40.46.734133		EUR	-11	SEPA-Lastschrift	Allianz Elementar Versicherungs-Aktiengesellschaft Hietzinger Kai 101-105 1130 Wien
AT5	1	04.01.2016	04.01.2016	2016-01-04-12.40.46.668468		EUR	-27,3	SEPA-Lastschrift	Wüstenrot Versicherungs-AG

<colgroup><col style="mso-width-source:userset;mso-width-alt:1389;width:29pt" width="38"> <col style="mso-width-source:userset;mso-width-alt:1609;width:33pt" width="44"> <col style="mso-width-source:userset;mso-width-alt:2596; width:53pt" width="71" span="2"> <col style="mso-width-source:userset;mso-width-alt:6436;width:132pt" width="176"> <col style="mso-width-source:userset;mso-width-alt:4242;width:87pt" width="116"> <col style="mso-width-source:userset;mso-width-alt:2633;width:54pt" width="72"> <col style="mso-width-source:userset;mso-width-alt:1974;width:41pt" width="54"> <col style="mso-width-source:userset;mso-width-alt:3876;width:80pt" width="106"> <col style="mso-width-source:userset;mso-width-alt:19968;width:410pt" width="546"> </colgroup><tbody>
</tbody>

Example of Data

 

[silentwolf]

Hi Norie,
getting there but somewhere along the lines where to columns are refereing to are still not quite right ... (10, GuthabenCounter) or Guthaben(9, GuthabenCounter)
..
Should be a smal adjustment but not working just yet unfortunatelly I am about to head out but I will keep you posted

Cheers in the meantime for your help!!!!

 

[Norie]

(10, GuthabenCounter) and (9, GuthabenCounter) should refer to columns J and I respectively if I read your code correctly.

Perhaps you could explain further, based on the posted data, which columns are involved in the function?

I'm about to head of myself but I'll take a look later.

 

[silentwolf]

I have changed the line

Guthaben(10, GuthabenCounter) = LastschriftenTextUpdate(Guthaben(10, GuthabenCounter))
so in the local window it shows me correct the updatet version of the text.. however it is not populating the same worksheet again with the updatet text..(

I have missexplained it at the beginning I like to find values in column("I") and if it matches then the function update("J") and should write it back into the same worksheet.
The changed line does the above but with the update in the same worksheet not (

Thanks for your input!!

Much very much appreciated!!

 

[silentwolf]

Hi Norie,

been trying something like that after the line ...Next r..

Range("J2").Offset(GuthabenCounter - 1, 0).Value = Guthaben 'In Range "J2" the values should start something still not working right.. hmm