HÜCRE İÇİNDEKİ METİNDE GEÇEN NOKTANIN KAÇ TANE OLDUĞUNU BULMAK VBA

[Mr. Köse]

Selamlar, örnek verecek olursam sayfadaki A3 hücresi içindeki metin 100.1.2 ve bu metindeki toplam 2 adet nokta sayısı var, vba kodu ile hücredeki nokta sayısını bulmak yani 2 sayısını bulmak istiyorum, vba kodu nedir yardımcı olabilir misiniz.

 

[AdemCan]

Merhaba, bu kodu modül içine ekleyip sayfada =noktasay(A3) olarak kullanabilirsiniz.

Function noktasay(hucre As Range)
    noktasay = Len(hucre) - Len(WorksheetFunction.Substitute(hucre, ".", ""))
End Function

Spoyler: Sonuç

 

[Mr. Köse]

Merhaba, bu kodu modül içine ekleyip sayfada =noktasay(A3) olarak kullanabilirsiniz.

Function noktasay(hucre As Range)
    noktasay = Len(hucre) - Len(WorksheetFunction.Substitute(hucre, ".", ""))
End Function

Spoyler: Sonuç

Ekli dosyayı görüntüle 249251

Teşekkür ederim Ademcan bey, kod sorunsuz çalışıyor.

 

[Mr. Köse]

Teşekkür ederim Ademcan bey, kod sorunsuz çalışıyor.

adem bey, nokta sayısına göre hücrelere farklı biçimlendirme yapıyorum, kalın, italic, altını çizme v.s. gibi dolayısıyla kod çalışıyor ancak yaklaşık 1000 satıra uyguladığım için çok ağır çalışıyor, başka kod öneriniz var mı?

 

[Mr. Köse]

adem bey, nokta sayısına göre hücrelere farklı biçimlendirme yapıyorum, kalın, italic, altını çizme v.s. gibi dolayısıyla kod çalışıyor ancak yaklaşık 1000 satıra uyguladığım için çok ağır çalışıyor, başka kod öneriniz var mı?

Pardon adem bey yavaş çalışmasının biçimleme, sizin kodunuz hızlı çalışıyor. Yazdığım kod aşağıdaki gibidir, çalışıyor ama biçimlendirme uzun sürüyor. Önerisi olan var mıdır?


'Program çalışma kitabı
Dim wb1 As Workbook
Dim s1 As Worksheet


'program çalışma kitabını tanımla
Set wb1 = ThisWorkbook
Set s1 = wb1.Worksheets("hesapplan")

Worksheets("hesapplan").Select
s1.Range("d:d").Select
Selection.ClearContents


Dim sonsat As Long
sonsat = s1.Range("a" & Rows.Count).End(xlUp).Row

For i = 2 To sonsat

s1.Cells(i, 4) = Len(s1.Cells(i, 1)) - Len(WorksheetFunction.Substitute(s1.Cells(i, 1), ".", ""))


If s1.Cells(i, 4) = 0 Then
s1.Cells(i, 1).Font.Bold = False
s1.Cells(i, 1).Font.Underline = xlUnderlineStyleNone
s1.Cells(i, 2).Font.Bold = False
s1.Cells(i, 2).Font.Underline = xlUnderlineStyleNone
s1.Cells(i, 3).Font.Bold = False
s1.Cells(i, 3).Font.Underline = xlUnderlineStyleNone

s1.Cells(i, 1).Font.Bold = True
s1.Cells(i, 1).Font.Underline = xlUnderlineStyleSingle
s1.Cells(i, 2).Font.Bold = True
s1.Cells(i, 2).Font.Underline = xlUnderlineStyleSingle
s1.Cells(i, 3).Font.Bold = True
s1.Cells(i, 3).Font.Underline = xlUnderlineStyleSingle

end if

next
end sub

 

[AdemCan]

Merhaba, kontrol eder misiniz?

Sub test()
Application.ScreenUpdating = False
'Program çalışma kitabı
Dim wb1 As Workbook, s1 As Worksheet, sonsat As Long

'program çalışma kitabını tanımla
Set wb1 = ThisWorkbook
Set s1 = wb1.Worksheets("hesapplan")

'Worksheets("hesapplan").Select
s1.Range("d:d").ClearContents
'Selection.ClearContents

sonsat = s1.Range("a" & Rows.Count).End(xlUp).Row
s1.Range("A2:D" & sonsat).ClearFormats

For i = 2 To sonsat

s1.Cells(i, 4) = Len(s1.Cells(i, 1)) - Len(WorksheetFunction.Substitute(s1.Cells(i, 1), ".", ""))

    If s1.Cells(i, 4) = 0 Then
    's1.Cells(i, 1).Font.Bold = False
    's1.Cells(i, 1).Font.Underline = xlUnderlineStyleNone
    's1.Cells(i, 2).Font.Bold = False
    's1.Cells(i, 2).Font.Underline = xlUnderlineStyleNone
    's1.Cells(i, 3).Font.Bold = False
    's1.Cells(i, 3).Font.Underline = xlUnderlineStyleNone
    
    With s1.Range("A" & i & ":C" & i)
        .Font.Bold = True
        .Font.Underline = xlUnderlineStyleSingle
    End With
    
    's1.Cells(i, 1).Font.Bold = True
    's1.Cells(i, 1).Font.Underline = xlUnderlineStyleSingle
    's1.Cells(i, 2).Font.Bold = True
    's1.Cells(i, 2).Font.Underline = xlUnderlineStyleSingle
    's1.Cells(i, 3).Font.Bold = True
    's1.Cells(i, 3).Font.Underline = xlUnderlineStyleSingle
    End If
Next
Application.ScreenUpdating = False
End Sub

 

[Mr. Köse]

Merhaba, kontrol eder misiniz?

Sub test()
Application.ScreenUpdating = False
'Program çalışma kitabı
Dim wb1 As Workbook, s1 As Worksheet, sonsat As Long

'program çalışma kitabını tanımla
Set wb1 = ThisWorkbook
Set s1 = wb1.Worksheets("hesapplan")

'Worksheets("hesapplan").Select
s1.Range("d:d").ClearContents
'Selection.ClearContents

sonsat = s1.Range("a" & Rows.Count).End(xlUp).Row
s1.Range("A2:D" & sonsat).ClearFormats

For i = 2 To sonsat

s1.Cells(i, 4) = Len(s1.Cells(i, 1)) - Len(WorksheetFunction.Substitute(s1.Cells(i, 1), ".", ""))

    If s1.Cells(i, 4) = 0 Then
    's1.Cells(i, 1).Font.Bold = False
    's1.Cells(i, 1).Font.Underline = xlUnderlineStyleNone
    's1.Cells(i, 2).Font.Bold = False
    's1.Cells(i, 2).Font.Underline = xlUnderlineStyleNone
    's1.Cells(i, 3).Font.Bold = False
    's1.Cells(i, 3).Font.Underline = xlUnderlineStyleNone
   
    With s1.Range("A" & i & ":C" & i)
        .Font.Bold = True
        .Font.Underline = xlUnderlineStyleSingle
    End With
   
    's1.Cells(i, 1).Font.Bold = True
    's1.Cells(i, 1).Font.Underline = xlUnderlineStyleSingle
    's1.Cells(i, 2).Font.Bold = True
    's1.Cells(i, 2).Font.Underline = xlUnderlineStyleSingle
    's1.Cells(i, 3).Font.Bold = True
    's1.Cells(i, 3).Font.Underline = xlUnderlineStyleSingle
    End If
Next
Application.ScreenUpdating = False
End Sub

Teşekkürler Adem bey, benim koduma nazaran oldukça hızlı sizin kod, sağolun.

 

[AdemCan]

Rica ederim.