Makro Çalışırken Userfrom Penceresindeki Hata

[akmes]

Selamlar,Ekte gönderdiğim excel sayfasının Sayfa2 deki Makroyu çalıştırdıktan sonra bekleme esnasında çıkan userfrom istediğim gibi görüntülenmiyor bu konuda yardımınızı rica ediyorum.Ayrıca kullandığım makro çok ağır işlem yapıyor bu konuda hızlandırmak mümkünmüdür?Yardımlarınız için şimdiden teşekkür edirim.

 

[hamitcan]

Dosyanızı düzenledim.

 

[akmes]

Elinize sağlık, çok teşekkür ederim

 

[akmes]

Hocam şimdi bir deneme yaptım Ben daha fazla veri aktardım ilk sayfaya siz süre girmişiniz o süre içersinde userfrom çıkıyor ve işleminin tamamdır diyor.Tamam tuşuna basınca esas makro çalışmaya başlıyor ama bekleme userfromu gözükmüyor.

 

[hamitcan]

Bence, siz, en iyisi progressbar nesnesi kullanın. Bu şekilde istediğiniz sonucu alamayacaksınız.

 

[Korhan Ayhan]

Selamlar,

Bu gibi durumlarda kod çalışırken açılan formun üzerindeki yazı normalde görüntelenemiyor. Fakat küçük bir eklemeyle bu işin üstesinden gelebilirsiniz.

Sub hepsi2()
    Dim lastrow As Long
    UserForm1.Show 0
[COLOR=red]    UserForm1.Repaint
[/COLOR]    Dim rng As Range
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim iStr As Integer
    Dim iBul As Integer
    Dim sAdr As String
    Set sh1 = Worksheets("Dekon Rapor")
    Set sh2 = Worksheets("Süzme")
    sh2.Cells.Clear
    sh1.Range("A2:H2").Copy sh2.Range("A1:H1")
    Set rng = sh1.Columns(1).Find("Kayıt Sayısı", lookat:=xlWhole)
    If Not rng Is Nothing Then
    iStr = 2
    sAdr = rng.Address
    iBul = rng.Row
    Do
    
    If sh1.Range("A" & iBul - 1) <> "Fiş No" Then
    
    sh1.Range("A" & iBul - 1 & ":H" & iBul - 1).Copy sh2.Range("A" & iStr & ":H" & iStr)
    sh2.Range("D" & iStr) = sh2.Range("D" & iStr) - sh1.Range("D" & iBul - 2)
    
    End If
    
    Set rng = sh1.Columns(1).FindNext(rng)
    
    iStr = iStr + 1: iBul = rng.Row
    
    Loop Until rng Is Nothing Or sAdr = rng.Address
    End If
    Set rng = Nothing
    Set sh1 = Nothing
    Set sh2 = Nothing
    Set s1 = Sheets("Süzme")
    Set s2 = Sheets("Sayfa1")
    s2.Range("A2:h65536").ClearContents
    a = Array(1, 2, 3, 4, 5, 6, 7, 8)
    sat = 1
    For x = 2 To s1.[a65536].End(3).Row
    If s1.Cells(x, 2) > 0 Then
    sat = sat + 1
    For y = 1 To 7
    s2.Cells(sat, y) = s1.Cells(x, a(y - 1))
    Next
    End If
    Next x
    Sheets("Sayfa1").Range("A2:ı65536").Sort Sheets("Sayfa1").Range("ı2"), Order1:=xlDescending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    s2.Range("A2:G65536").ClearContents
    a = Array(13, 14, 15, 16, 17, 18, 19)
    sat = 1
    For x = 2 To s1.[a65536].End(3).Row
    If s1.Cells(x, 14) > 0 Then
    sat = sat + 1
    For y = 1 To 7
    s2.Cells(sat, y) = s1.Cells(x, a(y - 1))
    Next
    End If
    Next x
    On Error Resume Next
    lastrow = Sheets("Sayfa2").Cells(Rows.Count, "g").End(xlUp).Row
    For Each cell In Sheets("Sayfa2").Range("g2:g" & lastrow)
    cell.Value = Int(cell.Value)
    Next
    Unload UserForm1
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub