Makro revizyonu

[kamenzü]

Merhaba,

Aşağıdaki kodda revizyona ihtiyacım var,

SEBEP: normalde çalışması gereken şartlarda aksaklık meydana geliyor.

Hata kodu şu:

run-time error '-2147024773 (8007007b)

Bunu internetten araştırdım ancak bendeki sorunu anlatan birisine denk gelemedim,

Olay kısaca şöyle;

1. Bu kod ile bir listboxdan seçtiğim birden çok çalışma sayfasını PDF olarak kaydedebiliyorum,

2. Dosya adını A1:E2 aralığında bulunan ve formülünde "UPPER" ifadesi olan hücrenin değeri olarak belirliyor.

ANCAK; bazı çalışma sayfalarında yukarıdaki hata kodunu veriyor.

Hata verdiği sayfayı tek olarak seçersem problem yok, PDF olarak kaydediyor,

Hata vermeyen birkaç sayfayı seçersem, hepsini problemsiz olarak PDF dosyaları olarak kaydediyor.

Sıkıntı sadece Hata veren sayfayı diğerleriyle beraber seçtiğimde oluyor.

Bu kodu nasıl revize edebiliriz veya basitleştirebiliriz.

Kod aşağıdadır ve arıza çıkaran kısım ise koyu olarak işaretlenmiştir.

Private Sub CheckBox1_Click()
Dim liste As Integer

For liste = 1 To ListBox1.ListCount
ListBox1.Selected(liste - 1) = CheckBox1.Value
Next
End Sub
Private Sub CommandButton1_Click()
Dim liste As Integer

For liste = 1 To ListBox1.ListCount
If ListBox1.Selected(liste - 1) = True Then
Sheets(ListBox1.List(liste - 1, 0)).PrintOut
ListBox1.Selected(liste - 1) = False
End If
Next
End Sub
[B]Private Sub CommandButton2_Click()
    Application.ScreenUpdating = False
Dim liste As Integer

For liste = 1 To ListBox1.ListCount
If ListBox1.Selected(liste - 1) = True Then
       For Each alan In Sheets(ListBox1.List(liste - 1, 0)).Range("A1:Z3")
        If alan.Formula Like "*" & "UPPER" & "*" Then
            adres = alan.Address
            Exit For
        End If
    Next
    End If
Next
    If adres = "" Then
        MsgBox "Yanlış Sayfa Seçtiniz", vbCritical
        Exit Sub
    End If
    
    Yol = ActiveWorkbook.Path & Application.PathSeparator
    
    For X = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(X) = True Then
            Sheets(ListBox1.List(X)).Copy
            ActiveSheet.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=Yol & Range(adres) & ".pdf", _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=False
            ActiveWindow.Close 0
        End If
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub[/B]Private Sub ListBox1_Click()

End Sub

Private Sub UserForm_Initialize()
ListBox1.ListStyle = 1
ListBox1.MultiSelect = fmMultiSelectExtended
For i = ActiveWorkbook.Sheets.Count To 1 Step -1
ListBox1.AddItem Sheets(i).Name
Next i

End Sub

 

[kamenzü]

Örnek dosya linki;

Burada örnek dosya ve kodun bulunduğu eklenti dosyası bulunmaktadır.

https://drive.google.com/open?id=0B0xWiOxM0J_eeTRvVGhUMzNvZ0U&authuser=0

 

[kamenzü]

Hatayı "LST-17", "LST-14" ve "LST-13" isimli çalışma sayfalarında vermektedir.

O hariç diğer "LST-..." çalışma sayfalarında düzgün çalışıyor.

Bu arada koddaki A1:E2 aralığını;

A1:Z3 olarak genişlettim.

 

[kamenzü]

Konu aktiftir...