[ÇÖZÜLDÜ] Comboboxlar Aracılığıyla Süzerek Listview'e Aktarma

[hsayar]

Hocam Dediğiniz gibi ondalık yaracım virgül ve bu TürkçeWindows Kurulumunda Otomatik olan bir şey diye biliyorum (çünkü ben değiştirmedim)
Replace lı örnek verebilirmisiniz.

Mümkünse Sistemin veya Excelin Ondalık ayracı "," ise
Değiştirsin. Değil ise sizin dediğiniz gibi devam etsin.. yani hiç bir kullanıcıda sorun çıkmasın.
Mümkün değilse replaceyi yapalım duruma göre daha sonra hareket ederim.

 

[veyselemre]

ThisWorkbook kısmına aşağıdaki kodları deneyin

Private Sub Workbook_Open()
    With Application
        .DecimalSeparator = "."
        .ThousandsSeparator = ","
        .UseSystemSeparators = False
    End With
End Sub

 

[hsayar]

replace yapılmasını istediğiniz sanırım kırımız metin hocam... ancak bunu sistemin ondalık yaracına göre yapsak daha iyi olmaz mı.
nokta ise bir şey yapmasın nokta değil ise mevcutu nokta olarak değiştirsin

Sub dicAl()
    Sheets("DATA").Select
    Set dic = CreateObject("Scripting.Dictionary")
    a = Range(Range("C5:J5"), Range("C5:I5").End(xlDown)).Value
    For X = 1 To UBound(a)
        al = ""
        For Y = 4 To 7
            al = al & a(X, Y) & "¦"
        Next Y
        If dic.Exists(al) = False Then
            ReDim w(0 To 2, 0)
            w(0, 0) = a(X, 1)
            w(1, 0) =[COLOR=red] a(X, 8) 'Dizide Tutarların bulunduğu kolon[/COLOR]
......

Replace işlemini şu şkilde yapmak mümkün mü?

Sub dicAl()
    Sheets("DATA").Select
    Set dic = CreateObject("Scripting.Dictionary")
    a = Range(Range("C5:J5"), Range("C5:I5").End(xlDown)).Value
    For X = 1 To UBound(a)
        al = ""
        For Y = 4 To 7
            al = al & a(X, Y) & "¦"
        Next Y
        If dic.Exists(al) = False Then
            ReDim w(0 To 2, 0)
            w(0, 0) = a(X, 1)
            sisondayr = [COLOR=red]???????[/COLOR]
            if sisondayr = "." Then
                     w(1, 0) =[COLOR=red] a(X, 8) 'Dizide Tutarların bulunduğu kolon[/COLOR]
            Else
                      w(1, 0) =[COLOR=red] Replace (a(X, 8), sisondayr, ".") 'Dizide Tutarların bulunduğu kolon[/COLOR]
[COLOR=#ff0000]           end if[/COLOR]
......

Bu arada sistem ondalık ayracı olarak . ve , den başka işaret kulanılmaktamıdır buda kafama takıldı.

 

[hsayar]

hocam bütün a(x,8) leri repalce ettim olmadı..
En başta for döngüsünün altına yazıdım olmadı

Sub dicAl()
    Sheets("DATA").Select
    Set dic = CreateObject("Scripting.Dictionary")
    a = Range(Range("C5:J5"), Range("C5:I5").End(xlDown)).Value
    For X = 1 To UBound(a)
      [COLOR=red][B]  a(X, 8) = (Replace(a(X, 8), ",", ".")) * 1
[/B][/COLOR]

 

[veyselemre]

Önce binlik ayıracı olan noktaları yok edin ondan sonra virgülleri noktaya çevirin.

a(X, 8)=REPLACE(REPLACE(Replace(a(X, 8),".",""),",",".")

Ama bu şekilde gereksiz işlem yaparak makineyi zorlamanın vakit kaybetmenin anlamı yok. Bölgesel ayarlarınızı değiştirin işinizi kolaylaştırın.

 

[hsayar]

Önce binlik ayıracı olan noktaları yok edin ondan sonra virgülleri noktaya çevirin.

a(X, 8)=REPLACE(REPLACE(Replace(a(X, 8),".",""),",",".")

Ama bu şekilde gereksiz işlem yaparak makineyi zorlamanın vakit kaybetmenin anlamı yok. Bölgesel ayarlarınızı değiştirin işinizi kolaylaştırın.

hocam haklısınız ancak bu şekilde yazmaya ve tabloları okumaya gerek ben gerekse patron alışkın değil.... bilindiği üzere Türkiye'de rakamların yazılışında ondalık ayraç olarak "," ve basamak ayracı olarak "." kullanımı okuldan beri alıştığımız olay olduğu için 30'undan sonra bu alışakanlığın değişmesi epey zor olacaktır.

 

[hsayar]

ThisWorkbook kısmına aşağıdaki kodları deneyin

Private Sub Workbook_Open()
    With Application
        .DecimalSeparator = "."
        .ThousandsSeparator = ","
        .UseSystemSeparators = False
    End With
End Sub

hocam bu kodlar benim sistemimde çalışmadı yani tepki vermedi Ofis2007, winXp

Önce binlik ayıracı olan noktaları yok edin ondan sonra virgülleri noktaya çevirin.

a(X, 8)=REPLACE(REPLACE(Replace(a(X, 8),".",""),",",".")

Ama bu şekilde gereksiz işlem yaparak makineyi zorlamanın vakit kaybetmenin anlamı yok. Bölgesel ayarlarınızı değiştirin işinizi kolaylaştırın.

Sub dicAl()
    Sheets("DATA").Select
    Set dic = CreateObject("Scripting.Dictionary")
    a = Range(Range("C5:J5"), Range("C5:I5").End(xlDown)).Value
    For X = 1 To UBound(a)
    a(X, 8) = [COLOR=red]Replace[/COLOR](Replace(Replace(a(X, 8), ".", ""), ",", "."))

seçili gelip argumanent not optinal diyor.

 

[hsayar]

şimdilik dediğiniz gbi bölgesel ayarları değiştirerek kullanıyorum ama çok zor olacak... ve kullanacağım her makinede bu işemi yaptırmak problem olacaktır.

 

[veyselemre]

Replace nin biri fazla olmuş kontrol etmeden yazmıştım. Aşağıdaki gibi deneyin.

a(X, 8) = [COLOR=red][/COLOR]Replace(Replace(a(X, 8), ".", ""), ",", ".")

 

[Tasarım]

Replace nin biri fazla olmuş kontrol etmeden yazmıştım. Aşağıdaki gibi deneyin.

a(X, 8) = [COLOR=red][/COLOR]Replace(Replace(a(X, 8), ".", ""), ",", ".")

Sayın Veysel bey bu arada bende kendi sorunumu dile getirmek istiyorum. Sorunum kısaca şöyle:

Formda bir adet Listbox var ve içerisinde çeşitli veriler var. Ben Textbox kutusuna yazdığım veriyi Excel'i kullanmadan sadece Listbox'ta süzmek istiyorum. Bunu en kısa ve anlaşılır yoldan nasıl yapabilirim? Forumu 2 gündür araştırıyorum ancak böyle bir soruyla veya bilgiye rastlayamadım.

 

[hsayar]

hocam dediğiniz şekilde yaptım ancak aynı başlıktan birden fazla varsa toplamı hatalı veriyor ve lw üzerindeki görüntü 100 le çarpılmış gibi oluyor

Sub dicAl()
    Sheets("DATA").Select
    Set dic = CreateObject("Scripting.Dictionary")
    SnlTab = Range(Range("C5:J5"), Range("C5:I5").End(xlDown)).Value
    For X = 1 To UBound(SnlTab)
[COLOR=red]   SnlTab(X, 8) = Replace(Replace(SnlTab(X, 8), ".", ""), ",", ".")[/COLOR]
'Debug.Print SnlTab(X, 8)
        al = ""
        For Y = 4 To 7
            al = al & SnlTab(X, Y) & "¦"
        Next Y
        If dic.Exists(al) = False Then
            ReDim YrdTab(0 To 2, 0)
            YrdTab(0, 0) = SnlTab(X, 1)
            YrdTab(1, 0) = SnlTab(X, 8)
            YrdTab(2, 0) = 1
            dic.Add al, YrdTab
        Else
            YrdTab = dic(al)
            For g = LBound(YrdTab, 2) To UBound(YrdTab, 2)
                If YrdTab(0, g) = SnlTab(X, 1) Then
                   YrdTab(1, g) = Val(YrdTab(1, g)) + Val(SnlTab(X, 8))
                   YrdTab(2, g) = Val(YrdTab(2, g)) + 1
                   dic(al) = YrdTab
                   GoTo var
                End If
            Next g
            ReDim Preserve YrdTab(0 To 2, 0 To UBound(YrdTab, 2) + 1)
            YrdTab(0, UBound(YrdTab, 2)) = SnlTab(X, 1)
            YrdTab(1, UBound(YrdTab, 2)) = SnlTab(X, 8)
            YrdTab(2, UBound(YrdTab, 2)) = 1
            dic(al) = YrdTab
        End If
var:
    Next X
Erase SnlTab
End Sub

http://img356.imageshack.us/my.php?image=ekranalntsiz6.jpg

 

[veyselemre]

Sayın Hsayar, replaceleri iptal edin, kodlardaki val fonksiyonlarını cdbl la değiştirip bir dener misiniz?

 

[hsayar]

Sayın Veysel bey bu arada bende kendi sorunumu dile getirmek istiyorum. Sorunum kısaca şöyle:

Formda bir adet Listbox var ve içerisinde çeşitli veriler var. Ben Textbox kutusuna yazdığım veriyi Excel'i kullanmadan sadece Listbox'ta süzmek istiyorum. Bunu en kısa ve anlaşılır yoldan nasıl yapabilirim? Forumu 2 gündür araştırıyorum ancak böyle bir soruyla veya bilgiye rastlayamadım.

Veyel beyin bu mesajındaki ekli dosya işinize yarayabilir...
http://www.excel.web.tr/showpost.php?p=175856&postcount=10

 

[hsayar]

Sayın Hsayar, replaceleri iptal edin, kodlardaki val fonksiyonlarını cdbl la değiştirip bir dener misiniz?

Sn veyselemre bu cdbl ne fonksiyonmuş ! ustanın camı üflemedeki sırı gibi.
inşallah büyük sayılarda bproblem yaşamam. (12-13 milyon ytl lerde yani)

http://img356.imageshack.us/my.php?image=ekranalntsnoktavirguldb7.jpg

[/



Kodlarda değişklik yapıldıktan sonraki durum aşağıdaki gibidir.
Hafızada yer tutmaması için silinmesi gereken değişkenler hala varsa söylerseniz onlarıda düzeltirim. benim gözüme combolor takıldı, onuda düzelttim.

Dim dic As Dictionary
Dim combolar()
Dim islemDevam As Boolean
Sub dicAl()
    Sheets("DATA").Select
    Set dic = CreateObject("Scripting.Dictionary")
    SnlTab = Range(Range("C5:J5"), Range("C5:J5").End(xlDown)).Value
    For X = 1 To UBound(SnlTab)
        Debug.Print "SnlTab(" & X & ", 8)=  " & SnlTab(X, 8)
        al = ""
        For Y = 4 To 7
            al = al & SnlTab(X, Y) & "¦"
        Next Y
        If dic.Exists(al) = False Then
            ReDim YrdTab(0 To 2, 0)
            YrdTab(0, 0) = SnlTab(X, 1)
            YrdTab(1, 0) = SnlTab(X, 8)
            YrdTab(2, 0) = 1
            dic.Add al, YrdTab
        Else
            YrdTab = dic(al)
            For g = LBound(YrdTab, 2) To UBound(YrdTab, 2)
                If YrdTab(0, g) = SnlTab(X, 1) Then
                   YrdTab(1, g) = CDbl(YrdTab(1, g)) + CDbl(SnlTab(X, 8))
                   YrdTab(2, g) = CDbl(YrdTab(2, g)) + 1
                   dic(al) = YrdTab
                   GoTo var
                End If
            Next g
            ReDim Preserve YrdTab(0 To 2, 0 To UBound(YrdTab, 2) + 1)
            YrdTab(0, UBound(YrdTab, 2)) = SnlTab(X, 1)
            YrdTab(1, UBound(YrdTab, 2)) = SnlTab(X, 8)
            YrdTab(2, UBound(YrdTab, 2)) = 1
            dic(al) = YrdTab
        End If
var:
    Next X
Erase SnlTab
End Sub
Private Sub cmb_BYil_Change()
    If islemDevam = False Then Call comboTextHazirla
End Sub
Private Sub cmb_mYil_Change()
    If islemDevam = False Then Call comboTextHazirla
End Sub
Private Sub cmb_GTur_Change()
    If islemDevam = False Then Call comboTextHazirla
End Sub
Private Sub cmb_mMer_Change()
    If islemDevam = False Then Call comboTextHazirla
End Sub
Private Sub Lvw_AdSoyad_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
    With Lvw_AdSoyad
        .Sorted = True
        .SortOrder = 1
        .SortKey = ColumnHeader.Index - 1
        .Sorted = False
    End With
End Sub
Private Sub UserForm_Initialize()                '##'
    Cbx_AdSoyad.Caption = "Tüm  Sayfaları  Seç"  '##'
    Call Esc_Ile_Cik
    Call ListWiev_Sutun_Basliklari
    Call dicAl
    combolar = Array("cmb_bYil", "cmb_mYil", "cmb_gTur", "cmb_mMer")
    For X = 0 To 3
        With Controls(combolar(X))
            .Style = fmStyleDropDownList
        End With
    Next
    Call comboTextHazirla
End Sub                                          '##'
Sub comboTextHazirla()
    kriter = ""
    For X = 0 To 3
        With Controls(combolar(X))
            If .Text <> "" Then
                kriter = kriter & .Text & "¦"
            Else
                kriter = kriter & "*¦"
            End If
        End With
    Next X
    islemDevam = True
    On Error Resume Next
    lst = dic.Keys
    For X = 0 To 3
        With Controls(combolar(X))
            Set col = New Collection
            txt = .Text
            .Clear
            For Each elem In lst
                If elem Like kriter Then
                    a = Split(elem, "¦")
                    col.Add a(X), a(X)
                End If
            Next
            bas = 1
basla:
            For i = bas To col.Count - 1
                For ii = i + 1 To col.Count
                    If StrComp(col(i), col(ii), vbTextCompare) = 1 Then
                        tmp = col(i)
                        col.Remove i
                        col.Add tmp, tmp
                        bas = i
                        GoTo basla
                    End If
                Next ii
            Next i
            For t = 1 To col.Count
                .AddItem col(t)
            Next
            Set col = Nothing
            .Text = txt
            .AddItem "*", 0
        End With
    Next X
    islemDevam = False
    On Error GoTo 0
    With Lvw_AdSoyad
        .ListItems.Clear
        For X = 0 To UBound(lst)
            If lst(X) Like kriter Then
                a = Split(lst(X), "¦")
                YrdTab = dic(lst(X))
                For ii = LBound(YrdTab, 2) To UBound(YrdTab, 2)
                    Z = Z + 1
                    .ListItems.Add , , YrdTab(0, ii)
                    For t = 0 To 3
                        .ListItems(Z).SubItems(t + 1) = a(t)
                    Next t
                    '.ListItems(Z).SubItems(5) = Format(YrdTab(1, ii), "#,##0.00")  'veyselemre
                    .ListItems(Z).SubItems(5) = Format(YrdTab(1, ii), "#,##0.00") 'hsayar
                    .ListItems(Z).SubItems(6) = YrdTab(2, ii)
                    bTop = bTop + CDbl(YrdTab(1, ii))
                    bSay = bSay + CDbl(YrdTab(2, ii))
                Next ii
            End If
        Next X
        Label12.Caption = "Listelenen İçerik Sayısı : " & .ListItems.Count & "      Listeleme Kriteri :[" & kriter & "]" & "      Listelenen Başlık Toplamı :[" & Format(bTop, "#,##0.00") & "]" & "      Listelenen Başlık Sayısı:[" & Format(bSay, "#,##0") & "]"
    End With
End Sub
Sub Esc_Ile_Cik()
    Cmd_Cikis.Cancel = True                      'Userform üzerinde "ESC" ye basınca çıkışa izin ver.  '##'
End Sub
Private Sub Cmd_Cikis_Click()
    Unload Me
End Sub
Sub ListWiev_Sutun_Basliklari()
    With Lvw_AdSoyad                             '##'
        .View = lvwReport
        .LabelEdit = lvwManual                   '##'
        .CheckBoxes = True                       'Her elemana CheckBox oluşturur.   '##'
        .ColumnHeaders.Clear
        .ListItems.Clear                         'başlıkları ve öğeleri temizle   '##'
        .ColumnHeaders.Add , , "Adı Soyadı", 142    'başlık ve genişliklerini ayarla     '##'
        .ColumnHeaders.Add , , "Bütçe Yılı", 50, lvwColumnRight
        .ColumnHeaders.Add , , "Mali Yılı", 50, lvwColumnRight
        .ColumnHeaders.Add , , "Gider Türü", 100
        .ColumnHeaders.Add , , "Masraf Merkezi", 100
        .ColumnHeaders.Add , , "BaşlıkToplamları", 70, lvwColumnRight
        .ColumnHeaders.Add , , "Başlık Sayısı", 30, lvwColumnRight
    End With                                     'Lvw_AdSoyad                                                                              '##'
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Set dic = Nothing
    Erase combolar
End Sub

 

[veyselemre]

Form kapanırken hafızada kalan başka bir değişken gözükmüyor, diğerleri prosedür içinde geçerli değişkenler olduğu için kapanırken hafızadan siliniyor, debug.print kısmını da rem lerseniz kodlarda bir sorun yok gibi.

 

[hsayar]

Form kapanırken hafızada kalan başka bir değişken gözükmüyor, diğerleri prosedür içinde geçerli değişkenler olduğu için kapanırken hafızadan siliniyor, debug.print kısmını da rem lerseniz kodlarda bir sorun yok gibi.

Emekleriniz ve alakanız içim tekrar teşekkür ederim.
Kolay gelsin.