Progressbar

[leyhus]

Selamun aleykum arkadaşlar. aşağıdaki makroda izin sayfasındaki bilgileri bordro sayfasına atıyor. ama programın biraz daha görsel olması için bu bilgileri aktarırken progressbar'ın çalışmasını istiyorum.ama bir türlü beceremiyorum. yardımcı olursanız sevinirim.

Sub PUAN_AKTAR()
Set SP = Sheets("PUAN")
Set SB = Sheets("BORDRO")
ORTALAMA_PUAN = SP.[C130]

Application.Calculation = xlCalculationManual
For X = 2 To SB.[A65536].End(3).Row
SAY = WorksheetFunction.CountIf(SP.Columns("A:A"), SB.Cells(X, 2))
On Error Resume Next
ARA = SP.Columns("A:A").Find(What:=SB.Cells(X, 2), LookAt:=xlWhole).Row
If SAY = 0 Then
SB.Cells(X, 9) = ORTALAMA_PUAN
Else
SB.Cells(X, 9) = SP.Cells(ARA, 3)
End If
Next
Application.Calculation = xlCalculationAutomatic
MsgBox "PUANLAR BAŞARIYLA AKTARILMIŞTIR.", vbInformation
Exit Sub
HATA: MsgBox "İŞLEMİNİZDE HATA OLUŞMUŞTUR." & Chr(10) & Chr(10) & "LÜTFEN GİRDİĞİNİZ BİLGİLERİ KONTROL EDİNİZ.", vbCritical, "DİKKAT !"
End Sub

 

[alpi]

Formunuza bir ProgressBar ekleyin adını ProgressBar1 olmasına dikkat edin.
Aşağıdaki kodları kullanın.

Sub PUAN_AKTAR()
    Set SP = Sheets("PUAN")
    Set SB = Sheets("BORDRO")
    ORTALAMA_PUAN = SP.[C130]
    
    Application.Calculation = xlCalculationManual
    ProgressBar1.Max = SB.[A65536].End(3).Row
    For X = 2 To SB.[A65536].End(3).Row
        ProgressBar1.Value = ProgressBar1.Value + 1
        SAY = WorksheetFunction.CountIf(SP.Columns("A:A"), SB.Cells(X, 2))
        On Error Resume Next
        ARA = SP.Columns("A:A").Find(What:=SB.Cells(X, 2), LookAt:=xlWhole).Row
        If SAY = 0 Then
            SB.Cells(X, 9) = ORTALAMA_PUAN
        Else
            SB.Cells(X, 9) = SP.Cells(ARA, 3)
        End If
    Next
    Application.Calculation = xlCalculationAutomatic
    MsgBox "PUANLAR BAŞARIYLA AKTARILMIŞTIR.", vbInformation
    Exit Sub
HATA:     MsgBox "İŞLEMİNİZDE HATA OLUŞMUŞTUR." & Chr(10) & Chr(10) & "LÜTFEN GİRDİĞİNİZ BİLGİLERİ KONTROL EDİNİZ.", vbCritical, "DİKKAT !"
End Sub

 

[leyhus]

Teşekkür ederim Sayın Alpi,
Peki bu progressbar kodların neresine yerleştiriliyor. başka bir makroda bunun kodun neresine yazmam gerekiyor. Başka bir kodda denedim ama beceremedim. aşağıdaki kodun neresine yazmam gerekiyor.

Private Sub CommandButton1_Click()
Dim Hedef As Workbook
Application.ScreenUpdating = False

Set Veri = Workbooks("Nakit Liste").Sheets("Sayfa1").Range("A2" & [D65536].End(3).Row)
Set Hedef = Workbooks.Open("C:\Documents and Settings\Sicil\Desktop\İcmal.xls", False, False)

Workbooks("Nakit Liste").Activate
Say = WorksheetFunction.CountA([A2:A65536])
If Say = 0 Then GoTo Son

Veri.Copy

Hedef.Activate

Worksheets(1).Range("A65536").End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Say = WorksheetFunction.CountA([A2:A65536])
If Say = 1 Then GoTo Devam
If Say = 2 Then
[A2] = 1
[A3] = 2
GoTo Devam
End If
If Say > 2 Then
[A2] = 1
[A3] = 2
[A2:A3].AutoFill Destination:=Range("A2:A" & [B65536].End(3).Row)
GoTo Devam

Devam:
Cells.EntireColumn.AutoFit
[B2].Select
ActiveWorkbook.Save
ActiveWindow.Close

Veri.ClearContents
Set Hedef = Nothing
Set Veri = Nothing
End If
Application.ScreenUpdating = True
MsgBox "VERİLERİNİZ BAŞARIYLA AKTARILMIŞTIR.", vbInformation
Exit Sub
Son:
MsgBox "AKTARILACAK VERİ BULUNAMADI.", vbExclamation
End Sub

 

[leyhus]

cevap verecek yokmu

 

[leyhus]

tamam başardım. herkese teşekkür ederim sonunda yapabildim.