• DİKKAT

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

Listeleme

O

orkuncan5

Katılım
15 Nisan 2009
Mesajlar
197
Excel Vers. ve Dili
Office 2010 Tr
Excell tablomda 1-100 aralığında tabloda olan ve olmayan sayıları listeleyerek olmayanları kırmızı ve karşısında DİKKAT yazmasını nasıl sağlarım.
 

Ekli dosyalar

Merhaba,

Eğer 1-100 sayıları sabit değerlerse aşağıdaki kodu kullanabilirsiniz.

Kod: 
Option Explicit
 
Private Sub UserForm_Initialize()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Integer, Y As Byte
    Dim BUL As Range, ADRES As String
    Dim Sütun As Byte, Satır As Integer
 
    Application.ScreenUpdating = False
 
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets.Add
 
    With S2
 
        .Cells(1, 1) = 1
        .Range("A1:A100").DataSeries Rowcol:=xlColumns, Step:=1
 
        For X = 1 To .Cells(Rows.Count, 1).End(3).Row
            Set BUL = S1.Range("b:e").Find(.Cells(X, 1), , , xlWhole)
            If Not BUL Is Nothing Then
                ADRES = BUL.Address
                Do
                    If WorksheetFunction.CountIf(.Range("B" & X & ":IV" & X), S1.Cells(BUL.Row, 1)) = 0 Then
                        .Cells(X, 256).End(1).Offset(0, 1) = S1.Cells(BUL.Row, 1)
                    End If
                Set BUL = S1.Range("b:e").FindNext(BUL)
                Loop While Not BUL Is Nothing And BUL.Address <> ADRES
            Else
                .Cells(X, 256).End(1).Offset(0, 1) = "DİKKAT"
            End If
        Next
 
        Sütun = .Cells(1, 1).CurrentRegion.Columns.Count
 
        With ListView1
            .View = lvwReport
            .FullRowSelect = True
            .Gridlines = True
            .LabelEdit = lvwManual
            .ListItems.Clear
            .ColumnHeaders.Clear
            .FlatScrollBar = False
 
            With .ColumnHeaders
                .Add , , "sayı", 75
 
                For X = 1 To Sütun - 1
                    .Add , , "öğrenci-" & X, 75
                Next
            End With
 
            For X = 1 To S2.Cells(Rows.Count, 1).End(3).Row
                .ListItems.Add , , S2.Cells(X, 1)
                If S2.Cells(X, 2) = "DİKKAT" Then
                    .ListItems(X).ForeColor = vbRed
                End If
                
                Satır = Satır + 1
                For Y = 2 To Sütun
                    .ListItems(Satır).SubItems(Y - 1) = S2.Cells(X, Y)
                Next
            Next
        End With
 
        Application.DisplayAlerts = False
        .Delete
        Application.DisplayAlerts = True
    End With
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
End Sub
 
orkuncan5' Alıntı:
Excell tablomda 1-100 aralığında tabloda olan ve olmayan sayıları listeleyerek olmayanları kırmızı ve karşısında DİKKAT yazmasını nasıl sağlarım.
Genişletmek için tıkla ...

O zaman onca uğraşılan teke indirme kodu boşuna gidecek galiba aşağıdaki kodu denermisiniz.

Kod: 
Private Sub UserForm_Initialize()
With ListView1
.View = lvwReport
.FullRowSelect = True
.Gridlines = True
.LabelEdit = lvwManual
.ListItems.Clear
.ColumnHeaders.Clear
.FlatScrollBar = False
With .ColumnHeaders
.Add , , "sayı", 75
For X = 1 To Cells(1, 255).End(xlToLeft).Column - 1
.Add , , "öğtenci-" & X, 75
Next
End With
End With
Set Sh = Sheets("Sayfa1")
For i = 1 To 100
sat = 0
ListView1.ListItems.Add , , i
ListView1.ListItems(i).ListSubItems.Add , , "dikkat"
ListView1.ListItems(i).ListSubItems(1).ForeColor = 255
ListView1.ListItems(i).ForeColor = 255
With Sh.Range("b2:e14")
Set d = .Find(What:=i, After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not d Is Nothing Then
FirstAddress = d.Address
Do
sat = sat + 1
ListView1.ListItems(i).ForeColor = -2147483640
ListView1.ListItems(i).SubItems(sat) = Sh.Cells(d.Row, 1)
ListView1.ListItems(i).ListSubItems(sat).ForeColor = -2147483640
Set d = .FindNext(d)
Loop While Not d Is Nothing And d.Address <> FirstAddress
End If
End With
Next
End Sub
 
Halit Bey sütun a sütun sayılarını atamasını yaptığınız yerde --variable not defined --uyarısı verdi
 
orkuncan5' Alıntı:
Halit Bey sütun a sütun sayılarını atamasını yaptığınız yerde --variable not defined --uyarısı verdi
Genişletmek için tıkla ...

Bunun yerine
Kod: 
Sütun = Cells(1, 1).CurrentRegion.Columns.Count

Bunu denermisiniz.

Kod: 
Sütun = Cells(1, 255).End(xlToLeft).Column
 
Korhan Bey ve Halit Bey ikinizin yaptığı çalışmada güzel ve iyi çalışıyor.Sağolun.
 
Yukarıdaki kodlar 1500 sayılık işlemi yaparken enazından 5 dk. sürmektedir.Bunu hızlandırmanın bir yolu varmıdır acaba.
 
Merhaba,

Aşağıdaki kodlar 1500 satırlık veride yaklaşık 15 saniyede tepki veriyor. Denermisiniz.

Kod: 
Option Explicit
 
Private Sub UserForm_Initialize()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Integer, Y As Byte
    Dim BUL As Range, ADRES As String
    Dim Sütun As Byte, Satır As Integer
 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets.Add
 
    With S2
 
        .Cells(1, 1) = 1
        .Range("A1:A1500").DataSeries Rowcol:=xlColumns, Step:=1
 
        For X = 1 To .Cells(Rows.Count, 1).End(3).Row
            Set BUL = S1.Range("B:E").Find(.Cells(X, 1), , , xlWhole)
            If Not BUL Is Nothing Then
                ADRES = BUL.Address
                Do
                    If WorksheetFunction.CountIf(.Range("B" & X & ":IV" & X), S1.Cells(BUL.Row, 1)) = 0 Then
                        .Cells(X, 256).End(1).Offset(0, 1) = S1.Cells(BUL.Row, 1)
                    End If
                Set BUL = S1.Range("B:E").FindNext(BUL)
                Loop While Not BUL Is Nothing And BUL.Address <> ADRES
            Else
                .Cells(X, 256).End(1).Offset(0, 1) = "DİKKAT"
            End If
        Next
 
        Sütun = .Cells(1, 1).CurrentRegion.Columns.Count
 
        With ListView1
            .View = lvwReport
            .FullRowSelect = True
            .Gridlines = True
            .LabelEdit = lvwManual
            .ListItems.Clear
            .ColumnHeaders.Clear
            .FlatScrollBar = False
 
            With .ColumnHeaders
                .Add , , "sayı", 75
 
                For X = 1 To Sütun - 1
                    .Add , , "Öğrenci-" & X, 75
                Next
            End With
 
            For X = 1 To S2.Cells(Rows.Count, 1).End(3).Row
                .ListItems.Add , , S2.Cells(X, 1)
                If S2.Cells(X, 2) = "DİKKAT" Then
                    .ListItems(X).ForeColor = vbRed
                End If
                
                Satır = Satır + 1
                For Y = 2 To Sütun
                    .ListItems(Satır).SubItems(Y - 1) = S2.Cells(X, Y)
                Next
            Next
        End With
 
        Application.DisplayAlerts = False
        .Delete
        Application.DisplayAlerts = True
    End With
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
 
orkuncan5' Alıntı:
Yukarıdaki kodlar 1500 sayılık işlemi yaparken enazından 5 dk. sürmektedir.Bunu hızlandırmanın bir yolu varmıdır acaba.
Genişletmek için tıkla ...

Kendi örnek dosyanızı ekleseydiniz daha iyi gözlemlerdik.

3000 sayılık işlemi örnek dosyada bu bilgisayarın hızına göre değişir

37-41 saniye arası veriyi aktarıyor.

Kod: 
Private Sub UserForm_Initialize()
zaman = TimeValue(Now)
With ListView1
.View = lvwReport
.FullRowSelect = True
.Gridlines = True
.LabelEdit = lvwManual
.ListItems.Clear
.ColumnHeaders.Clear
.FlatScrollBar = False
With .ColumnHeaders
.Add , , "sayı", 75
For X = 1 To Cells(1, 255).End(xlToLeft).Column - 1
.Add , , "öğtenci-" & X, 75
Next
End With
End With
Set Sh = Sheets(ActiveSheet.Name)
For i = 1 To 3000
ListView1.ListItems.Add , , i
sat = 0
With Sh.Range("b2:e65536")
Set d = .Find(What:=i, After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not d Is Nothing Then
FirstAddress = d.Address
Do
sat = sat + 1
ListView1.ListItems(i).SubItems(sat) = Sh.Cells(d.Row, 1)
Set d = .FindNext(d)
Loop While Not d Is Nothing And d.Address <> FirstAddress
Else
ListView1.ListItems(i).ListSubItems.Add , , "dikkat"
ListView1.ListItems(i).ListSubItems(1).ForeColor = 255
ListView1.ListItems(i).ForeColor = 255
End If
End With
Next
MsgBox Format(TimeValue(Now) - zaman, "hh.ss")
End Sub
 

Ekli dosyalar

Korhan Bey ve Ömer Bey Vermiş oldunuz örnekler için,harcadığınız zaman için ve kendinizi yorduğunuz için teşekkür ederim.Ben bu kodları başka bir proğramda kullandığım için biraz ağır çalıştı.Hemen hemen 110 sütun 1500 satırlık bir veride çalıştırdığım için ağır çalışıyor.
 
Merhaba,

ListView gibi döngü yöntemi ile veri yüklenen bir nesneye 110*1500 hücrelik veriyi yüklemeye çalışırsanız yavaşlama yaşamanız gayet doğaldır.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst