Makro yapıştırma

[Serdarrk]

Aşağıdaki linkteki dosyada bulunan excel sayfalarından 2 ile bitenleri 1 ile bitenlerin M sütunundan itibaren yapıştıracak bir makro mümkün mü?


http://s7.dosya.tc/server3/4k92fi/01-Agu-2001-1.XLS.html

 

[Necdet]

Merhaba,

Dosyanızın yedeğini aldıktan sonra aşağıdaki kodları bir modüle kopyalayıp deneyiniz.

Not : Aktarılacak sayfa yoksa açar.

Sub Aktar()

    Dim i   As Long, _
        Adt As Integer, _
        Syf As Worksheet, _
        Yen As String, _
        Ash As String
    
    Ash = ActiveSheet.Name
    
    Application.ScreenUpdating = False
    
    For Each Syf In Worksheets
    
        If Right(Syf.Name, 1) = 2 Then
        
            Adt = Adt + 1
            Yen = Left(Syf.Name, Len(Syf.Name) - 1) & 1
            If Not SayfaVarMi(Yen) Then
                Sheets.Add After:=Worksheets(Worksheets.Count)
                ActiveSheet.Name = Yen
                Sheets(Ash).Select
            End If

            i = Sheets(Yen).Cells.Find("*", , , , xlByRows, xlPrevious).Row
            Syf.Range("A1:K" & i).Copy Sheets(Yen).Range("M1")
            
        End If
            
    Next Syf
    
    Application.ScreenUpdating = True
    MsgBox Adt & " Adet Sayfa Kopyalandı...."
    

End Sub

Function SayfaVarMi(SayfaAdi As String) As Boolean
    On Error Resume Next
    SayfaVarMi = CBool(Len(Worksheets(SayfaAdi).Name) > 0)
End Function

 

[Serdarrk]

Necdet Bey, ilginiz,vaktiniz ve emeğiniz için çok teşekkür ederim. Lütfen ayırdığınız vaktinizi, emeğinizi helal edin. Sizin için çok küçük ama benim için çok büyük bir yardım. Gerçekten çok teşekkür ederim.

 

[Necdet]

Güle güle kullanınız.