Progressbar

[cocoa35]

Merhaba, Aşağıda ekli olan kodlara Progressbar eklemek istiyorum ancak tam olarak çalışmıyor. Kodlarda nerde hata yapıyorum acaba?

Private Sub CommandButton1_Click()
Worksheets("PID1").Unprotect "12345"
Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
For i = 1 To 100
x = x + 1
Bar3.Width = x * 2.3
Barlbl.Caption = "% " & Int(x / 100 * 57)
DoEvents
Set S1 = Sheets("PID1")
Set S2 = Sheets("HESAPLAR")
Set S3 = Sheets("PROSES HESAP KOD")

Application.ScreenUpdating = False
S1.Rows("79:117").EntireRow.Hidden = False
S1.Rows("352:390").EntireRow.Hidden = False
S1.Rows("391:429").EntireRow.Hidden = False
S1.Rows("430:468").EntireRow.Hidden = False
S1.Rows("469:507").EntireRow.Hidden = False
S1.Rows("508:546").EntireRow.Hidden = False
If S2.[H383] = 2 Then
S1.Rows("79:117").EntireRow.Hidden = True
End If
If S3.[I126] = 2 Then
S1.Rows("391:429").EntireRow.Hidden = True
S1.Rows("430:468").EntireRow.Hidden = True
S1.Rows("469:507").EntireRow.Hidden = True
S1.Rows("508:546").EntireRow.Hidden = True
End If
If S3.[I128] = 2 And S3.[I131] = 1 Then
S1.Rows("352:390").EntireRow.Hidden = True

End If
If S3.[I126] = 1 And S3.[N144] = 2 Then
S1.Rows("469:507").EntireRow.Hidden = True

End If
Next i
MsgBox "İşlem tamam"
Unload Me
Worksheets("PID1").Protect "12345"
End Sub

 

[cocoa35]

Arkadaşlar bu konuda yardım lütfen, progressbar kod'larını nasıl düzenlemeliyim?

 

[Trilenium]

For i = 1 To 100
x = x + 1
Bar3.Width = x * 2.3
Barlbl.Caption = "% " i / 100* 100

DoEvents

dener misiniz

 

[cocoa35]

Sn. Trilenium Denedim olmadı dahası program kilitlendi.

 

[Trilenium]

For i = 1 To 100
x = x + 1
ProgressBar1.Width = x * 2.3
ProgressBar1 = i / 100 * 100
DoEvents

 

[cocoa35]

Konuya cevap yazan arkadaşlara teşekkür ediyorum ancak maalesef bu çözümler çalışmıyor. denedim hepsini başka çözüm açısından fikri olan varmı acaba?

 

[Zeki Gürsoy]

Kodu inceleyin...

Private Sub CommandButton1_Click()
    Const msg1 = "İşlem tamam."
    Const msg2 = "Bir hata oluştu. Orj. hata mesajı:" & vbCrLf
   
    Worksheets("PID1").Unprotect "12345"

    On Error GoTo handler
   
    Application.ScreenUpdating = False
   
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, bWidth As Single, forCount As Integer
   
    bWidth = Bar3.Width ' Normal uzunlukta olduğu varsayıldı...
   
    Bar3.Width = 0
   
    forCount = 100
   
    For i = 1 To forCount
   
        Bar3.Width = bWidth * (i / forCount)
        Barlbl.Caption = "% " & Int(100 * (Bar3.Width / bWidth))
       
        DoEvents
       
        Set S1 = Sheets("PID1")
        Set S2 = Sheets("HESAPLAR")
        Set S3 = Sheets("PROSES HESAP KOD")
       
        S1.Rows("79:117").EntireRow.Hidden = False
        S1.Rows("352:390").EntireRow.Hidden = False
        S1.Rows("391:429").EntireRow.Hidden = False
        S1.Rows("430:468").EntireRow.Hidden = False
        S1.Rows("469:507").EntireRow.Hidden = False
        S1.Rows("508:546").EntireRow.Hidden = False
       
        If S2.[H383] = 2 Then S1.Rows("79:117").EntireRow.Hidden = True
       
        If S3.[I126] = 2 Then
            S1.Rows("391:429").EntireRow.Hidden = True
            S1.Rows("430:468").EntireRow.Hidden = True
            S1.Rows("469:507").EntireRow.Hidden = True
            S1.Rows("508:546").EntireRow.Hidden = True
        End If
       
        If S3.[I128] = 2 And S3.[I131] = 1 Then S1.Rows("352:390").EntireRow.Hidden = True
        If S3.[I126] = 1 And S3.[N144] = 2 Then S1.Rows("469:507").EntireRow.Hidden = True
       
    Next i
   
    Application.ScreenUpdating = True
   
handler:
    MsgBox IIf(Err.Number = 0, msg1, msg2 & Err.Description)
    Err.Clear
    Unload Me
    Worksheets("PID1").Protect "12345"
 
End Sub

.