Sayfalarda yazanları bir sayfada sıralama

[td877]

Arkadaşlar merhaba,

Birden çok sayfamın olduğu ve bir de icmal sayfamın olduğu çalışmamda, sayfalarda alt alta yazan ilgili verileri, icmal sayfamda sayfa adı altına veriler olarak birleştirmek istiyorum.

Yani kısaca şu

1. Sayfa nın adı
veriler
2. sayfanın adı
veriler
3. sayfanın adı
veriler
.
.
.
vs

gibi


Örnek dosyam ektedir.,

Yardımcı olabilirseniz çok mutlu olacağım.

 

[Necdet]

Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz.

Sub SayfadaBirlestir()

    Dim Shi As Worksheet, _
        sh  As Worksheet, _
        i   As Long, _
        j   As Long
    
    Set Shi = Sheets("İCMAL")
    
    Application.ScreenUpdating = False
        
    i = Shi.Cells.Find("*", , , , xlByRows, xlPrevious).Row
    
    If i < 5 Then i = 5
    
    Shi.Range("A5:B" & i).ClearContents
    
    For Each sh In Worksheets
    
        If Not sh.Name = Shi.Name Then
            i = Shi.Cells(Rows.Count, "A").End(3).Row + 1
            j = sh.Cells(Rows.Count, "E").End(3).Row
            Shi.Cells(i, "A") = sh.Name
            i = i + 1
            sh.Range("E2:F" & j).Copy
            Shi.Range("A" & i).PasteSpecial xlPasteValues
        End If
        
    Next sh
    
    For i = Shi.Cells(Rows.Count, "A").End(3).Row To 5 Step -1
        If Shi.Cells(i, "B") = 0 Then Shi.Rows(i).Delete
    Next i
    
    Application.ScreenUpdating = True
    
    MsgBox "Aktarma İşlemi Bitmiştir....", vbInformation, "www.excel.web.tr -- Necdet"
    
End Sub


/CODE]

 

[td877]

Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz.

Sub SayfadaBirlestir()

    Dim Shi As Worksheet, _
        sh  As Worksheet, _
        i   As Long, _
        j   As Long
   
    Set Shi = Sheets("İCMAL")
   
    Application.ScreenUpdating = False
       
    i = Shi.Cells.Find("*", , , , xlByRows, xlPrevious).Row
   
    If i < 5 Then i = 5
   
    Shi.Range("A5:B" & i).ClearContents
   
    For Each sh In Worksheets
   
        If Not sh.Name = Shi.Name Then
            i = Shi.Cells(Rows.Count, "A").End(3).Row + 1
            j = sh.Cells(Rows.Count, "E").End(3).Row
            Shi.Cells(i, "A") = sh.Name
            i = i + 1
            sh.Range("E2:F" & j).Copy Shi.Range("A" & i)
        End If
       
    Next sh
   
    Application.ScreenUpdating = True
   
    MsgBox "Aktarma İşlemi Bitmiştir....", vbInformation, "www.excel.web.tr -- Necdet"
   
End Sub

Hocam teşekkür ederim ".PasteSpecial Paste:=xlPasteValues" şu codu ekleyebilir miyiz peki, formulle değil de direkt değerle aktarmasını istiyorum.

 

[çıtır]

Alternatif olarak.

Sub aktar()
Dim i As Integer: Dim ii As Integer:Dim s1 As Worksheet:Set s1 = Sheets("İCMAL")
 Application.ScreenUpdating = False
s1.Range("A3:B" & Rows.Count).Cells.ClearContents
s1.Range("A4") = "POZ": s1.Range("B4") = "ADET"
sat = 5
For i = 1 To Worksheets.Count
sayfaadı = Worksheets(i).Name
If sayfaadı <> "İCMAL" Then
 son = Worksheets(i).Range("E65355").End(3).Row
 s1.Range("A" & sat) = Worksheets(i).Name
 sat = sat + 1
 For ii = 2 To son
  If Worksheets(i).Range("F" & ii) > 0 Then
 s1.Range("A" & sat) = Worksheets(i).Range("E" & ii)
 s1.Range("B" & sat) = Worksheets(i).Range("F" & ii)
 sat = sat + 1
End If
 Next ii
  End If
Next i
 Application.ScreenUpdating = True
MsgBox "İŞLEM TAMAM", vbInformation, "BİLGİNİZE"
End Sub

 

[Necdet]

Merhaba,
Kodu değiştirdim, aslında siz de yapabilirdiniz sanırım. İlk mesajımdaki kodları deneyiniz.

 

[td877]

Sayın çıtır çok teşekkür ederim.

Sayın Necdet çok teşekkür ederim. Macro konusunda bilme ile bilmeme arasında bir yerdeyim ondan direkt uzmanından yardım almak istedim

 

[çıtır]

Sayın çıtır çok teşekkür ederim.

Sayın Necdet çok teşekkür ederim. Macro konusunda bilme ile bilmeme arasında bir yerdeyim ondan direkt uzmanından yardım almak istedim

Rica ederim.Dönüş yaptığınız için teşekkür ederim.

 

[td877]

İlave bişey sorabilir miyim biraz kullanınca karşıma çıktı, adet sütununda "0" rakamı varsa veya boşsa çektirmeme işlemi yapılabilir mi?

 

[Necdet]

Merhaba,

2. nolu mesajdaki kodlar yenilenmiştir.