Teks omzetten naar getal, duurt erg lang

[HWV]

Beste,

Hier op het formum dit script gehaald om tekst om te zetten naar getal via VBA.
Ik heb dit script verwerkt in mijn code ( ik roep deze aan vanuit een ander macro).
Ik laat dit script over de rond 4400 regels lopen die gevuld zijn.
Echter hij doet er verschrikkelijk lang over.

Als ik de niet via de VBA code doet dan gaat het binnen enkel seconden, maar moet dit in mijn conversie meenemen dus VBA is gewenst.

Nu kom de vraag kan dit niet sneller.

Sub TekstNaarGetallen()

Dim C As Range, T As String, T2 As Integer, T3 As Integer

        Columns("H1:H4400").Select
    On Error Resume Next
    For Each C In Selection
        C.Replace _
            What:=Chr(160), _
            Replacement:=Chr(32)
        'vaste spaties omzetten in spaties
        T = Trim(C.Value)
        With Application.WorksheetFunction
            T2 = .Find(".", T)
            T3 = .Find(".", T, T2 + 1)
        End With
        If IsEmpty(C) Then
        'overslaan lege cellen
        ElseIf LCase(C.Value) Like "*[a-z]*" Then
        'overslaan cellen met letters
        ElseIf C.Value Like "*[@$#;:/\]*" Then
        'overslaan tekens
        ElseIf T3 - T2 = 2 Or T3 - T2 = 3 Then
        'twee punten in een getal overslaan
        Else
            If C.Value Like "*.*" Then
                C.Replace _
                    What:=".", _
                    Replacement:=""
            End If
            
            If IsNumeric(C) Then
            'datum getallen negeren
                C.NumberFormat = "general"
                'celopmaak instellen
                C.Value = C.Value * 1
            End If
        
        End If
    Next

    On Error GoTo 0
    ' Een kolom selecteren
    Columns("H:H").Select
' Maken dat hij financieel wordt met een euro teken
    Selection.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
       
End Sub

Groet HWV

 

[leofact]

De lusse zullen sneller doorlopen worden als je aan het begin van de procedure het volgende zet.

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Aan het eind moet je deze weer op true zetten en calculation op xlCalculationAutomatic

mvg leo

 

[HWV]

Geprobeerd

Beste,

Bedankt voor de input.

Application.ScreenUpdating = False
Application.EnableEvents = False

Deze had ik al in de code staan, waarvandaan ik de code opvraag. De andere code

Application.Calculation = xlCalculationManual

Daar had ik nog niet van gehoord. Deze heb ik toegvoegd aan het script.
Helaas is hij zo op het eerst zicht niet sneller geworden ivm dat hij nu al weer 10 minuten staat te draaien op deze kolom.

Ik heb het bestand toegevoegd, in de hoop dat er een oplossing is om dit sneller te doen verlopen.

Groet HWV

 

[Warme bakkertje]

Henk, met onderstaande regel laat je hem ook een volledige kolom doorlopen zijnde 65536 cellen

Columns("H:H").Select

Gooi die regel eruit en gebruik onderstaande ipv in Selection

For Each C In Range("H4", Range("H65536").End(xlUp))

Op ong. 10 sec was hij erdoor

Mvg

Rudi

 

[leofact]

gezien de teskst van het sheet volstaat Val(c) ook.
Of zie ik dit te eenvoudig?
Dan wordt de proceduere:

Sub TekstNaarGetallen()

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Dim C As Range, T As String, T2 As Integer, T3 As Integer

        Columns("H:H").Select
    On Error Resume Next
    For Each C In Selection
         If C > 0 Then C = Val(C)
    Next

    On Error GoTo 0
    ' Een kolom selecteren
    Columns("H:H").Select
' Maken dat hij financieel wordt met een euro teken
    Selection.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
    
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

End Sub

 

[HWV]

gaat toch nog niet goed

Rudi,

Ik heb de code aangepast. Hij gaf de melding dat er al een For was.
Ik heb dit veranderd die er al in stond en de code als volgt gemaakt:

Sub TekstNaarGetallen()

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Dim C As Range, T As String, T2 As Integer, T3 As Integer
    On Error Resume Next
For Each C In Range("H4", Range("H65536").End(xlUp))
        C.Replace _
            What:=Chr(160), _
            Replacement:=Chr(32)
        'vaste spaties omzetten in spaties
        T = Trim(C.Value)
        With Application.WorksheetFunction
            T2 = .Find(".", T)
            T3 = .Find(".", T, T2 + 1)
        End With
        If IsEmpty(C) Then
        'overslaan lege cellen
        ElseIf LCase(C.Value) Like "*[a-z]*" Then
        'overslaan cellen met letters
        ElseIf C.Value Like "*[@$#;:/\]*" Then
        'overslaan tekens
        ElseIf T3 - T2 = 2 Or T3 - T2 = 3 Then
        'twee punten in een getal overslaan
        Else
            If C.Value Like "*.*" Then
                C.Replace _
                    What:=".", _
                    Replacement:=""
            End If
            
            If IsNumeric(C) Then
            'datum getallen negeren
                C.NumberFormat = "general"
                'celopmaak instellen
                C.Value = C.Value * 1
            End If
        
        End If
    Next

    On Error GoTo 0
    ' Een kolom selecteren
    Columns("H:H").Select
' Maken dat hij financieel wordt met een euro teken
    Selection.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
    
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

End Sub

Ik zit nu weer op ruim 4 minuten toen heb ik heb het gestopt.

Heb ik de code verkeerd toegepast

Groet Henk

 

[Ginger]

HWV, Wat denk je van deze super snelle en super korte oplossing?

Sub ff()

    With Range("H4:H4136")
        .Replace ",", "."
        .NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
    End With
    
End Sub

Groet, Leo

 

[HWV]

Perfect

Leo,

Bedankt voor deze bijdrage, werkt als een trein.
Toegepast in de totale script, en gaat er rap doorheen, je merkt niet dat hij daarop blijf hangen.

Ik wil de rest die een bijdrage heeft geleverd bedanken voor zijn input.

Groet Henk