• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

ikikan

ikikan

Katılım
3 Mart 2009
Mesajlar
519
Excel Vers. ve Dili
excel 2003 tr
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
Genişletmek için tıkla ...

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?
 
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?
Genişletmek için tıkla ...

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
 
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)")
 
=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")
 
Son düzenleme:
Ç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.
 
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
Genişletmek için tıkla ...
 
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
Genişletmek için tıkla ...

Halit bey birden fazla sütun olursa her bir sütünun mak değerini bulabilirmiyiz?
 
ikikan' Alıntı:
Halit bey birden fazla sütun olursa her bir sütünun mak değerini bulabilirmiyiz?
Genişletmek için tıkla ...

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
 
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
 
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.
 
Son düzenleme:
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.
Genişletmek için tıkla ...

Denedim Omerceri bey lakin koda yinele fonksiyonunuda ekliyeceğim sizin verdiğiniz kod ile istediğim aralıgın mak değerini alamıyorum.
 
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
 
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
 

Ekli dosyalar

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
Genişletmek için tıkla ...

Bu kodu ben yazmadım onun için bir şey yapamıyorum.
Bu kodun ne işe yaradığınıda bilmiyorum.
İyi Çalışmalar
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst