Sayfaları Tek Sayfada Toplama

[ANTALYA 01]

Merhabalar
Ekteki Çalışmada Sayfalardaki Plaklara Göre Sayfa 1'e Sayfalardaki B3 Satırındaki Plakaları ve 10 .Satırdan itibaren verileri aktaracak makroya ihtiyacım bulunmaktadır.Tşk.

 

[meslan]

Merhaba,

Sub aktar()
Columns("a:ı").ClearContents
For y = 2 To Sheets.Count
For x = 10 To Sheets(y).[a65536].End(3).Row
son = [a65536].End(3).Row + 1
Cells(son, 1) = Sheets(y).Name
Range("b" & son & ":ı" & son).Value = Sheets(y).Range("a" & x & ":h" & x).Value
Next
Next
End Sub

Kolay gelsin.

 

[Recep İpek]

Aşağıdaki kodları deneyiniz.

Sub Raporla()
On Error Resume Next
Dim i As Integer
Dim sadi As Worksheet
Dim kisi As String
Application.ScreenUpdating = False
Set s1 = Sheets("Sayfa1")
s1.Range("a2:I1000").ClearContents
    For Each sadi In Worksheets
        If sadi.Name <> "Sayfa1" Then
            Set s2 = Sheets(sadi.Name)
                For i = 10 To s2.[a65536].End(xlUp).Row
                    sat = s1.[a65536].End(3).Row + 1
                    s1.Cells(sat, "a").Value = s2.Cells(3, "b").Value
                    s1.Cells(sat, "b").Value = s2.Cells(i, "a").Value
                    s1.Cells(sat, "c").Value = s2.Cells(i, "b").Value
                    s1.Cells(sat, "d").Value = s2.Cells(i, "c").Value
                    s1.Cells(sat, "e").Value = s2.Cells(i, "d").Value
                    s1.Cells(sat, "f").Value = s2.Cells(i, "e").Value
                    s1.Cells(sat, "g").Value = s2.Cells(i, "f").Value
                    s1.Cells(sat, "h").Value = s2.Cells(i, "g").Value
                    s1.Cells(sat, "I").Value = s2.Cells(i, "h").Value
                Next i
        End If
    Set s2 = Nothing
    Next
s1.[a2].Select
Application.ScreenUpdating = True
MsgBox "İşlem Başarıyla Tamamlandı.", vbInformation, "Bilgi"
Set s1 = Nothing
End Sub

 

[ANTALYA 01]

G

Çok ama çok teşekkür ederim.Tam istediğim gibi olmuş.