Array ile hücre içindeki karakter sayısı

ikikan · 11 Mayıs 2013

Sub ddd()
Dim myarray() As Variant
a1 = Len(shf2.Range("B5:B5").Value)
a2 = Len(shf2.Range("B6:B6").Value)
a3 = Len(shf2.Range("B7:B7").Value)
myarray = Array(a1, a2, a3)
shf1.Range("a11").Value = Application.WorksheetFunction.Max(myarray)
End Sub

Arkadaşlar ben bir sütündaki hücrelerin içindeki karakter uzunluklarını en büyük değerini bulmaya çalışıyorum yukardaki kod ile bulunuyor ama her satır için a1 a2 a3 diye gitmem gerekiyor bunun bir kısa yolu varmıdır?

halit3 · 11 Mayıs 2013

ikikan' Alıntı:
Arkadaşlar ben bir sütündaki hücrelerin içindeki karakter uzunluklarını en büyük değerini bulmaya çalışıyorum yukardaki kod ile bulunuyor ama her satır için a1 a2 a3 diye gitmem gerekiyor bunun bir kısa yolu varmıdır?

WorksheetFunction uzunluk değerlerini alan özelliği yok galiba ondan bu uygulamayı alternatif olarak aşağıdaki kod ile döngüyle yaptım.

kod:

Kod:

Sub ddd()
Dim deg() As Variant
Dim i As Integer
For i = 1 To Cells(Rows.Count, "b").End(3).Row
ReDim Preserve deg(i)
deg(i) = Len(Cells(i, "b").Value)
Next i
Cells(11, "a").Value = Application.WorksheetFunction.Max(deg)
End Sub

Necdet · 12 Mayıs 2013

Merhaba,

Madem ki bir sütunda en fazla uzunluk değerini bulmak istiyorsanız neden dizi kullanıyorsunuz?

Kod:

Sub MakBul()
 
    Dim i   As Long, _
        Uz  As Integer
    For i = 2 To Cells(Rows.Count, "B").End(3).Row
        If Len(Cells(i, "B")) > Uz Then Uz = Len(Cells(i, "B"))
    Next i
 
    MsgBox "En Fazla Uzunluk : " & Uz
 
End Sub

Yada alternatif olarak

Kod:

 MsgBox Evaluate("=Max(B1:B20)")

omerceri · 12 Mayıs 2013

=MAK(UZUNLUK(A1:A10)) (Bu kodu yazdıktan sonra Ctrl+Shift+Enter basın
yukardaki dizi formülü veya aşağıdaki kod işinize yarar mı
Range("a11").FormulaArray = "=MAX(LEN(A1:A10))"
Range("a11").Value = Range("a11")

ikikan · 12 Mayıs 2013

Çok teşekürler üstatlar tüm kodlar işime yaradı. Necdet Bey bir kaç sütun daha eklemeyi düşünüyorum fakat sizleri çok oyalamak istemiyorum daha çok üstatlardan mantığını alıp kendimide birşeyler katmak, takıldiğim yerlerde sizlerden fikirler almak istiyorum, ve cidden teşekürler hiç yarı yolda kalmadım.

ikikan · 12 Mayıs 2013

Halit Bey haklısınız uzunluk değerinin alan değeri olmaması mak degerininde alan değeri olması sorun çıkarıyor, yabancı bir sitede su kodu buldum örnek olması için buraya koyuyorum.

Sub IfNotSorted()
Dim i As Byte
Dim StrLetter As String
Columns(2) = Columns(1).Value

On Error Resume Next
For i = 1 To 26
StrLetter = Choose(i, "a", "b", "c", "d", "e", "f", _
"g", "h", "i", "j", "k", "l", "m", "n", _
"o", "p", "q", "r", "s", "t", "u", "v", _
"w", "x", "y", "z")

Columns(2).Replace What:=StrLetter, Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Next i
On Error GoTo 0
MsgBox "Max is " & WorksheetFunction.Max(Columns(2))
End Sub

ikikan · 14 Mayıs 2013

halit3' Alıntı:
WorksheetFunction uzunluk değerlerini alan özelliği yok galiba ondan bu uygulamayı alternatif olarak aşağıdaki kod ile döngüyle yaptım.

kod:

Kod:

Sub ddd() Dim deg() As Variant Dim i As Integer For i = 1 To Cells(Rows.Count, "b").End(3).Row ReDim Preserve deg(i) deg(i) = Len(Cells(i, "b").Value) Next i Cells(11, "a").Value = Application.WorksheetFunction.Max(deg) End Sub

Halit bey birden fazla sütun olursa her bir sütünun mak değerini bulabilirmiyiz?

halit3 · 15 Mayıs 2013

ikikan' Alıntı:
Halit bey birden fazla sütun olursa her bir sütünun mak değerini bulabilirmiyiz?

Bu kod işinizi görürmü ?

Kod:

Sub ddd()
Dim deg() As Variant
Dim i As Integer, i As Integer
For Each X In Range("A1:M10")
If X.Value <> "" Then
i = i + 1
ReDim Preserve deg(i)
deg(i) = Len(X.Value)
End If
Next X
Cells(11, "a").Value = Application.WorksheetFunction.Max(deg)
End Sub

ikikan · 15 Mayıs 2013

Halit bey aslında istediğim her sütunun max değerini bulmak aşadaki mantıkta fakat altaki şekilde çok fazla kod yazmak gerekiyor.

sub ddd ()
say = Sheets("HES").ListBox1.ListCount - 1

For i = 0 To say
If Sheets("HES").ListBox1.Selected(i) = True Then
Dim d1(), d2(), d3(), d4(), d5(), d6(), d7(), d8(), d9(), d10() As Variant, f As Integer

For f = i + 5 To i + 5
ReDim Preserve d1(f), d2(f), d3(f), d4(f), d5(f), d6(f), d7(f), d8(f), d9(f), d10(f)
d1(f) = Len(shf2.Cells(f, "A").Value)
d2(f) = Len(shf2.Cells(f, "B").Value)
d3(f) = Len(shf2.Cells(f, "C").Value)
d4(f) = Len(shf2.Cells(f, "D").Value)
d5(f) = Len(shf2.Cells(f, "E").Value)
d6(f) = Len(shf2.Cells(f, "F").Value)
d7(f) = Len(shf2.Cells(f, "G").Value)
d8(f) = Len(shf2.Cells(f, "H").Value)
d9(f) = Len(shf2.Cells(f, "I").Value)
d10(f) = Len(shf2.Cells(f, "J").Value)

Next f
shf1.Cells(2, "C").Value = Application.WorksheetFunction.Max(d1)
shf1.Cells(2, "D").Value = Application.WorksheetFunction.Max(d2)
shf1.Cells(2, "E").Value = Application.WorksheetFunction.Max(d3)
shf1.Cells(2, "F").Value = Application.WorksheetFunction.Max(d4)
shf1.Cells(2, "G").Value = Application.WorksheetFunction.Max(d5)
shf1.Cells(2, "H").Value = Application.WorksheetFunction.Max(d6)
shf1.Cells(2, "I").Value = Application.WorksheetFunction.Max(d7)
shf1.Cells(2, "J").Value = Application.WorksheetFunction.Max(d8)
shf1.Cells(2, "K").Value = Application.WorksheetFunction.Max(d9)
shf1.Cells(2, "L").Value = Application.WorksheetFunction.Max(d10)
end sub

omerceri · 15 Mayıs 2013

Sn ikikan
Ne gerek var bu kadar koda, benim önerimi denediniz mi?

Kod:

Range("a11").FormulaArray = "=MAX(LEN(A1:A10))"
Range("b11").FormulaArray = "=MAX(LEN(B1:B10))"
Range("C11").FormulaArray = "=MAX(LEN(C1:C10))"
Range("a11:c11").FormulaArray = Range("a11:c11")()

Eğer hangi sütunlarda işlem yapılacağını sonuçların nereye yazılacağını belirtirseniz. Kod daha kısa ve esnek olarak yapılabilir.

ikikan · 15 Mayıs 2013

omerceri' Alıntı:
Sn ikikan
Ne gerek var bu kadar koda, benim önerimi denediniz mi?

Kod:

Range("a11").FormulaArray = "=MAX(LEN(A1:A10))" Range("b11").FormulaArray = "=MAX(LEN(B1:B10))" Range("C11").FormulaArray = "=MAX(LEN(C1:C10))" Range("a11").Value = Range("a11") Range("b11").Value = Range("b11") Range("c11").Value = Range("b11")

Eğer hangi sütunlarda işlem yapılacağını sonuçların nereye yazılacağını belirtirseniz. Kod daha kısa ve esnek olarak yapılabilir.

Denedim Omerceri bey lakin koda yinele fonksiyonunuda ekliyeceğim sizin verdiğiniz kod ile istediğim aralıgın mak değerini alamıyorum.

omerceri · 15 Mayıs 2013

Örnek dosya eklerseniz daha kolay sonuç alırsınız.

ikikan · 15 Mayıs 2013

Örnek dosya ektedir

halit3 · 15 Mayıs 2013

Ben sizin ne demek istediğinizi anlıyamıyorum
Sayın omerceri 'nin önerdiği en mantıklı olanı

Anladığım kadarı ile kodu yazdım.

Bu kod 10 sütunluk her sütunun en büyük değerini birinci satırlarına yazıyor hesaplamalara birinci satır dahil değildir.

kod:

Kod:

Sub ddd()
Dim deg() As Variant
Dim i As Integer, j As Integer
For j = 1 To 10
For i = 2 To Cells(Rows.Count, j).End(3).Row + 1
ReDim Preserve deg(i)
deg(i) = Len(Cells(i, j).Value)
Next i
Cells(1, j).Value = Application.WorksheetFunction.Max(deg)
Next
End Sub

ikikan · 21 Mayıs 2013

Halit bey vermiş oldugunuz kod ile istedğim sonuca ulaştım fakat fazla veri de kasıyor aşadaki kodu hızlandıra bilirmiyiz veya sadeleştirlebilirmi ?

Kod:

Option Explicit
Sub PROJE1()
Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
       'Application.EnableEvents = False
           Application.Volatile
           
Dim ss1, ss2, ss3, ss4, bitis, say, e, f, j, g, h, t As Integer
Dim sonuc, d1(), d2() As Variant
Dim i, Birlestir, a1, a2, a3, yinele, array_sayaci
Dim shf1, shf2 As Worksheet
Dim hucre, hucre1, hucre2 As Range

Set shf2 = Sheets("VG")

Set shf1 = Sheets("PROJE")
ss1 = shf1.Cells(Rows.Count, "F").End(3).Row
ss2 = shf2.Cells(Rows.Count, "A").End(3).Row
ss3 = shf2.Cells(ss2, Columns.Count).End(1).Column
ss4 = shf1.Cells(ss1, Columns.Count).End(1).Column
shf1.Range("A2:EL" & ss1).ClearContents
say = Sheets("HES").ListBox1.ListCount - 1

For i = 0 To say 'uzunluğun max değeri bulduk ve diğer satırların uzunluk değerlerini bulduk
If Sheets("HES").ListBox1.Selected(i) = True Then
For e = 1 To ss3
shf1.Cells(i + 2, e + 5).Value = shf2.Cells(i + 5, e).Value
For t = 1 To shf2.Cells(Rows.Count, e).End(3).Row - 4
shf1.Cells(t + 1, e + 31).Value = Len(shf1.Cells(t + 1, e + 5).Value)
ReDim Preserve d1(t)
d1(t) = Len(shf1.Cells(t + 1, e + 5).Value)
Next t
shf1.Cells(1, e + 5).Value = WorksheetFunction.Max(d1)
Next e

For j = 1 To ss2 ' max değerle diğer satır ve sütünların aralarındaki farkı bulduk
For g = 2 To ss2 - 3
If shf1.Cells(g, j + 5).Value = Empty Then
shf1.Cells(g, j + 31).Value = ""
Else
shf1.Cells(g, j + 31).Value = shf1.Cells(1, j + 5).Value - shf1.Cells(g, j + 31).Value
yinele = WorksheetFunction.Rept(" ", shf1.Cells(g, j + 31).Value)
shf1.Cells(g, j + 31).Value = yinele
End If
Next g
Next j

For h = 0 To i ' aradaki fark kadar yinelen değerlerle verileri eşit aralıkda birleştirdik yazı karakteri consolas olmalı
Birlestir = ""
For f = 1 To ss3
If shf1.Cells(h + 2, f + 5).Value = Empty Then
Birlestir = ""
Else
Birlestir = Birlestir & shf1.Cells(h + 2, f + 5).Value & " " & shf1.Cells(h + 2, f + 31).Text
End If
Next f
shf1.Cells(h + 2, 3).Value = Birlestir
Next h

End If
Next i

Call LİSTBOX1
shf1.Range("F1:BA" & ss2).ClearContents
' Bu kodu sadeleştirip hızlandıra bilirmiyim? kod çalışıyor ama cok fazla veri oldugunda kasıyor..

Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
        Application.EnableEvents = True
End Sub

halit3 · 22 Mayıs 2013

ikikan' Alıntı:

Halit bey vermiş oldugunuz kod ile istedğim sonuca ulaştım fakat fazla veri de kasıyor aşadaki kodu hızlandıra bilirmiyiz veya sadeleştirlebilirmi ?

Kod:

Option Explicit
Sub PROJE1()
Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
       'Application.EnableEvents = False
           Application.Volatile
           
Dim ss1, ss2, ss3, ss4, bitis, say, e, f, j, g, h, t As Integer
Dim sonuc, d1(), d2() As Variant
Dim i, Birlestir, a1, a2, a3, yinele, array_sayaci
Dim shf1, shf2 As Worksheet
Dim hucre, hucre1, hucre2 As Range

Set shf2 = Sheets("VG")

Set shf1 = Sheets("PROJE")
ss1 = shf1.Cells(Rows.Count, "F").End(3).Row
ss2 = shf2.Cells(Rows.Count, "A").End(3).Row
ss3 = shf2.Cells(ss2, Columns.Count).End(1).Column
ss4 = shf1.Cells(ss1, Columns.Count).End(1).Column
shf1.Range("A2:EL" & ss1).ClearContents
say = Sheets("HES").ListBox1.ListCount - 1

For i = 0 To say 'uzunluğun max değeri bulduk ve diğer satırların uzunluk değerlerini bulduk
If Sheets("HES").ListBox1.Selected(i) = True Then
For e = 1 To ss3
shf1.Cells(i + 2, e + 5).Value = shf2.Cells(i + 5, e).Value
For t = 1 To shf2.Cells(Rows.Count, e).End(3).Row - 4
shf1.Cells(t + 1, e + 31).Value = Len(shf1.Cells(t + 1, e + 5).Value)
ReDim Preserve d1(t)
d1(t) = Len(shf1.Cells(t + 1, e + 5).Value)
Next t
shf1.Cells(1, e + 5).Value = WorksheetFunction.Max(d1)
Next e

For j = 1 To ss2 ' max değerle diğer satır ve sütünların aralarındaki farkı bulduk
For g = 2 To ss2 - 3
If shf1.Cells(g, j + 5).Value = Empty Then
shf1.Cells(g, j + 31).Value = ""
Else
shf1.Cells(g, j + 31).Value = shf1.Cells(1, j + 5).Value - shf1.Cells(g, j + 31).Value
yinele = WorksheetFunction.Rept(" ", shf1.Cells(g, j + 31).Value)
shf1.Cells(g, j + 31).Value = yinele
End If
Next g
Next j

For h = 0 To i ' aradaki fark kadar yinelen değerlerle verileri eşit aralıkda birleştirdik yazı karakteri consolas olmalı
Birlestir = ""
For f = 1 To ss3
If shf1.Cells(h + 2, f + 5).Value = Empty Then
Birlestir = ""
Else
Birlestir = Birlestir & shf1.Cells(h + 2, f + 5).Value & " " & shf1.Cells(h + 2, f + 31).Text
End If
Next f
shf1.Cells(h + 2, 3).Value = Birlestir
Next h

End If
Next i

Call LİSTBOX1
shf1.Range("F1:BA" & ss2).ClearContents
' Bu kodu sadeleştirip hızlandıra bilirmiyim? kod çalışıyor ama cok fazla veri oldugunda kasıyor..

Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
        Application.EnableEvents = True
End Sub

Bu kodu ben yazmadım onun için bir şey yapamıyorum.
Bu kodun ne işe yaradığınıda bilmiyorum.
İyi Çalışmalar

Array ile hücre içindeki karakter sayısı

ikikan

halit3

Uzman

Necdet

Moderatör

omerceri

ikikan

ikikan

ikikan

halit3

Uzman

ikikan

omerceri

ikikan

omerceri

ikikan

Ekli dosyalar

halit3

Uzman

ikikan

Ekli dosyalar

halit3

Uzman