Macroyu tum sekmelerde tekrarlamak

[fredycrouger]

Merhabalar.

Elimdeki macro bir sekmede sorunsuz calisiyor fakat ayni macroyu diger sekmelerdede kullanmak istedigimde bunu basaramiyorum. Ikinci sekmeye gecmeden once araya ne koymam gerekiyor cozemedim. Yardimci olabilirseniz cok sevinirim.

Sub deletetabs()
'
' deletetabs Macro
'

'

Sheets("SRKO").Select
If IsEmpty(Range("A2")) = False Then

Dim str As String
Dim n As Integer

str = ActiveCell.Value

Cells(n + 1, 4).Select

Do Until Len(str) = 0

n = n + 1

Cells(n + 1, 4).Select
str = ActiveCell.Value

Cells(n + 1, 4).Value = Left(str, 11) & "-" & Right(str, 1)

Loop
Selection.EntireRow.Delete

Else
End If

Application.DisplayAlerts = False
Sheets("SRKO").Select
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True

____________ Ikinci sekmeye gecis____________

Sheets("ZUS").Select
If IsEmpty(Range("A2")) = False Then

Dim str As String
Dim n As Integer

str = ActiveCell.Value

Cells(n + 1, 4).Select

Do Until Len(str) = 0

n = n + 1

Cells(n + 1, 4).Select
str = ActiveCell.Value

Cells(n + 1, 4).Value = Left(str, 11) & "-" & Right(str, 1)

Loop
Selection.EntireRow.Delete

Else
End If
Application.DisplayAlerts = False
Sheets("ZUS").Select
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True

End Sub

 

[Muzaffer Ali]

Merhaba.

Bu kodlar her durumda belirtmiş olduğunuz iki sayfayı siliyor ben bişe anlamadım ama istediğiniz şekli aşağıda.

Sub deletetabs()
    Dim str As String
    Dim n As Integer
    Dim syfNo As Integer
    Dim Sayfalar(1) As Worksheet
    
    Set Sayfalar(0) = Sheets("SRKO")
    Set Sayfalar(1) = Sheets("ZUS")
    
    For syfNo = 0 To 1
        Sayfalar(syfNo).Select
        If IsEmpty(Range("A2")) = False Then
            Cells(n + 1, 4).Select
            Do Until Len(str) = 0
                n = n + 1
                str = Cells(n + 1, 4).Value
                Cells(n + 1, 4).Value = Left(str, 11) & "-" & Right(str, 1)
            Loop
            Selection.EntireRow.Delete
        End If
        Application.DisplayAlerts = False
        Sayfalar(syfNo).Delete
        Application.DisplayAlerts = True
    Next
End Sub

 

[fredycrouger]

Sn. @dalgalikur ozur dilerim cok haklisiniz, formulu tam ters olarak uygulamisim.

Amacim eger A2 hucresinde bir deger yok ise sekmeyi silmek, fakat A2 hucresinde bir deger var ise kodu calistirmak ve bu islemi 3 sekme icinde uygulamak. Hatta bir sekilde en basa her sekme icin eger var ise seklinde bir sinama koyabilirsem muhtesem olur.

Sekme var ise A2 hucresinde bir veri varmi ona bakmali - var ise kodu uygulayacak ve bir sonraki sekmeye gececek yok ise sekmeyi silecek.

Sekme yok ise bir sonraki sekmeye bakacak oda yok ise sonrakine.

Umarim cok karmasik olmamistir.

Zaman ayirdiginiz icin cok tesekkurler.

 

[muratb06]

Sub DeleteSheets()
Dim ws as Worksheet
For each ws in Thisworkbook.Worksheets
ws.Select
If Range("A2").Value <> " "
Hücre dolu ise yapılacak kodları buraya yazınız
Else
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End if
Next ws
End Sub

Cep telefonundan yazıyorum,deneme fırsatım olmadı. Umarım işinizi görür.

ASUS_Z00LD cihazımdan Tapatalk kullanılarak gönderildi

 

[Muzaffer Ali]

Sn. @dalgalikur ozur dilerim cok haklisiniz, formulu tam ters olarak uygulamisim.

Amacim eger A2 hucresinde bir deger yok ise sekmeyi silmek, fakat A2 hucresinde bir deger var ise kodu calistirmak ve bu islemi 3 sekme icinde uygulamak. Hatta bir sekilde en basa her sekme icin eger var ise seklinde bir sinama koyabilirsem muhtesem olur.

Sekme var ise A2 hucresinde bir veri varmi ona bakmali - var ise kodu uygulayacak ve bir sonraki sekmeye gececek yok ise sekmeyi silecek.

Sekme yok ise bir sonraki sekmeye bakacak oda yok ise sonrakine.

Umarim cok karmasik olmamistir.

Zaman ayirdiginiz icin cok tesekkurler.

Örnek dosyanızı eklerseniz daha iyi olur.
Kontrolü sağlanmayacak ve silinmeyecek sabit sayfalar olup olmadığı da önemli.
Onun için mümkünse dosyanın kendisini, değilse benzer bir örnek dosya hazırlayarak eklerseniz daha iyi olur.

 

[fredycrouger]

Sub DeleteSheets()
Dim ws as Worksheet
For each ws in Thisworkbook.Worksheets
ws.Select
If Range("A2").Value <> " "
Hücre dolu ise yapılacak kodları buraya yazınız
Else
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End if
Next ws
End Sub

Cep telefonundan yazıyorum,deneme fırsatım olmadı. Umarım işinizi görür.

ASUS_Z00LD cihazımdan Tapatalk kullanılarak gönderildi

Selamlar, Denedim ama calistiramadim.
Yinede tesekkurler.

 

[fredycrouger]

Sn. @dalgalikur ornek dosyayi ekledim. Icindede duzeltmeye calistigim kod mevcut. Sorun su ki calistirdiginizda sizinde goreceginiz gibi bazi satirlardaki kodlari direk atliyor ve calistirmiyor. Sorunun ne oldugunu cozemedim.

Dosya ile ilgili detaylar:

- 8 tane sekme var ve bu sekmelerin ilk 5 tanesi sabit ve her zaman dosya icerisinde mevcut.
- Son 3 sekme (SRKO,ZUS,BGO) degisken, bir gun birisi olabiliyor diger gun hepsi ya da iki tanesi. onun icin once sekme varmi yokmu onu sinamam gerekiyor.
- Kodun amaci: eger sekme icerisinde ikinci satirda veri var ise (kodda A2 hucresini kullandim) D2 hucresindeki veriye -1 ekleyecek ve bu sekilde son satira kadar devam edecek. Veri yok ise sekmeyi silecek.

Ornek:
BBT000138811 > BBT000138811-1
DFC000128412 >DFC000128412-1

- Ayni islemi SRKO sekmesinden sonra ZUS ve BGO icinde uygulayacak.

Ornek tablo: https://files.fm/u/n632dmyw

Umarim basinizi sisirmemisimdir.

 

[Muzaffer Ali]

Dosyanız ekte.

https://www.dosyaupload.com/a6qx

 

[fredycrouger]

Sn. @dalgalikur cok tesekkurler fakat kod sadece SRKO icin calisiyor, ZUS ve BGO sekmelerinde calismiyor.

 

[Muzaffer Ali]


For Each Sayfalar In ThisWorkbook.Worksheets

Satırının altına

n = 0
Ekleyin.

 

[fredycrouger]

Sn. @dalgalikur,

Uzerinde sizin kodunuzu kullanarak uzerinde calistigim kodu calisir hale getirdim. Simdi tek sorunum bu kodun devaminda ayni islemleri ZUS ve BGO icinde yapmasi icin ne yapmam gerekir ? Araya ne koyarak devam ettirebilirim ?

Else
End If ile devam etmeye calisirsam "Compile error" Duplicate declaration in current scope hatasi aliyorum.

Sub delete()
'
' delete Macro
'

'
Sheets("SRKO").Select
If IsEmpty(Range("A2")) = False Then

    Dim str As String
    Dim n As Integer

    str = Cells(n + 2, 4).Value
    
    Do Until Len(str) = 0

    n = n + 1
    str = Cells(n + 1, 4).Value

    Cells(n + 1, 4).Select
    str = ActiveCell.Value

    Cells(n + 1, 4).Value = Left(str, 11) & "-" & Right(str, 1)
    

    Loop
    Selection.EntireRow.delete

    
    Else
    End If
    
    If IsEmpty(Range("A2")) = True Then
    
Application.DisplayAlerts = False
    Sheets("SRKO").Select
    ActiveWindow.SelectedSheets.delete
    Application.DisplayAlerts = True
    
    Else
    End If
End Sub

 

[fredycrouger]

Sn. @dalgalikur

Bir onceki mesajimi gormezden gelebilirsiniz

Kod gayet guzel calisiyor, son bir duzeltmeye ihtiyacim kaldi. Loop yaparken son satirida tamamlayinca bir alt satirda ( - ) olusuyor. Ben onu onceki kodumda "Selection.EntireRow.delete" seklinde cozmustum (Loop sonrasinda). bos olan son satirdaki ( - ) hangi kodla silebilirim ?

tekrardan cok tesekkurler yardimlariniz icin.

 

[Muzaffer Ali]

8. mesajdaki dosyayı yeniledim yeniden indirip deneyin.

 

[fredycrouger]

8. mesajdaki dosyayı yeniledim yeniden indirip deneyin.

Cok tesekkurler ve iyi calismalar.