PROGRESSBAR EKLEME

[cocoa35]

Arkadaşlar merhaba; Ek'te örnek dosyada bulunan KABLO1 Sayfasındaki Değişik POZ'ları filtreleyerek KABLO Sayfasına aktaran Makro bulunmaktadır. İsteğim bu makroya ProgressBar eklemek , ben uğraştım ancak beceremedim bu konuda yardımınıza ihtiyacım var, Teşekkürler.

 

[zulfuernek]

Dim i As Integer
For i = 1 To 100
ProgressBar1.Value=i
Next i

Bu kodu butonla calostirmak istiyorsan butona ekle. Userform acilinca calkstirmak istiyorsanda userforma ekle

Daha sonra progressbar tamamlanincada yapilmasini jstediklerini kodlarin devamina ekle. Kld asagida

If ProgressBar1.Value = 100 Then
PorgressBar1.Visible = False 'progressbari gizler
'Yapmasini ksredkgin kodlarida buraya ekle
End If

 

[ÖmerBey]

Merhaba,
Kodunuzdaki döngüye kırmızı satırı ekleyiniz.

For i = 2 To sh1.Cells(65536, 4).End(xlUp).Row
    ProgressBar1.Value = (i / sh1.Cells(65536, 4).End(xlUp).Row) * ProgressBar1.Max
    Set rg = sh1.Range("D2:D" & i)

İyi çalışmalar...

 

[cocoa35]

Merhaba,
Kodunuzdaki döngüye kırmızı satırı ekleyiniz.

For i = 2 To sh1.Cells(65536, 4).End(xlUp).Row
    ProgressBar1.Value = (i / sh1.Cells(65536, 4).End(xlUp).Row) * ProgressBar1.Max
    Set rg = sh1.Range("D2:D" & i)

İyi çalışmalar...

Merhaba kod'u ekledim gayet güzel çalışıyor,çok teşekkür ederim, ancak ilerleme % 'ni göstermiyor bunu yapma imkanımız varmı? birde işlem bittiğinde " İşlem Tamamlanmıştır." diye mesaj verdirebilirmiyiz.

 

[ÖmerBey]

Progressbar varken bunlara gerek yok ama...
Siz bilirsiniz. Buyurunuz.

Private Sub CommandButton1_Click()
Set sh1 = Sheets("KABLO1")
Set sh2 = Sheets("KABLO")
sh2.Range("A:A").ClearContents
sh2.Cells(1, 1) = "Kablo Cinsi"
son = sh1.Cells(65536, 4).End(xlUp).Row
For i = 2 To son
    DoEvents
    ProgressBar1.Value = (i / son) * ProgressBar1.Max
    Label2.Caption = Int((i / son) * 100) & "% tamamlandı"
    Set rg = sh1.Range("D2:D" & i)
    If Application.WorksheetFunction.CountIf(rg, sh1.Cells(i, 4)) = 1 Then
       sh2.Cells(sh2.Cells(65536, 1).End(xlUp).Row + 1, 1) = sh1.Cells(i, 4)
    End If
    Set rg = Nothing
Next i
Set sh1 = Nothing
Set sh2 = Nothing
MsgBox " İşlem Tamamlanmıştır."
End Sub

 

[cocoa35]

Progressbar varken bunlara gerek yok ama...
Siz bilirsiniz. Buyurunuz.

Private Sub CommandButton1_Click()
Set sh1 = Sheets("KABLO1")
Set sh2 = Sheets("KABLO")
sh2.Range("A:A").ClearContents
sh2.Cells(1, 1) = "Kablo Cinsi"
son = sh1.Cells(65536, 4).End(xlUp).Row
For i = 2 To son
    DoEvents
    ProgressBar1.Value = (i / son) * ProgressBar1.Max
    Label2.Caption = Int((i / son) * 100) & "% tamamlandı"
    Set rg = sh1.Range("D2:D" & i)
    If Application.WorksheetFunction.CountIf(rg, sh1.Cells(i, 4)) = 1 Then
       sh2.Cells(sh2.Cells(65536, 1).End(xlUp).Row + 1, 1) = sh1.Cells(i, 4)
    End If
    Set rg = Nothing
Next i
Set sh1 = Nothing
Set sh2 = Nothing
MsgBox " İşlem Tamamlanmıştır."
End Sub

Çok Teşekküler tam istediğim gibi olmuş , iyiki varsınız.

 

[ÖmerBey]

Rica ederim, yardımcı olduysam ne mutlu.
İyi çalışmalar...