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.
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Teşekkür ederim Ademcan bey, kod sorunsuz çalışıyor.Merhaba, bu kodu modül içine ekleyip sayfada =noktasay(A3) olarak kullanabilirsiniz.
Kod:Function noktasay(hucre As Range) noktasay = Len(hucre) - Len(WorksheetFunction.Substitute(hucre, ".", "")) End Function
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ı?Teşekkür ederim Ademcan bey, kod sorunsuz çalışıyor.
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?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ı?
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.Merhaba, kontrol eder misiniz?
Kod: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