72 sayfa arasından 58 istenilen sayfadaki tabloları çekme

[inci55]

Merhaba arkadaşlar bütçe çalışmalarında kullandığımız bir dökümanımız var. Yaklaşık 72 sayfadan oluşuyor. Kimi sayfada 10 satır kimi sayfada 1500 satır var. İsteğim 72 sayfa arasından istediğim 58 sayfadaki verileri başka bir sayfada alt alta birleştirmek. Makro kaydet düğmesiyle 1 sayfada kayıt yaptım. Ancak sonra makroyu çalıştır dediğimde 1004 hatasını verdi.
Aslında işlem basit ismini verdiğim sayfaya gidecek, A1 kutusundan end tuşuna basıp önce shift-sağa sonra yine end tuşu ile shift-aşağı giderek bir alan seçecek sonra bu alanı kopyalayıp Hepsi sayfasına yapıştıracak.

Yardımcı olabilecek misiniz?

Sheets("Torbalama-2 S3M028").Select
        Application.Goto Reference:="R1C1"
	Range(Selection, Selection.End(xlToRight)).Select
    	Range(Selection, Selection.End(xlDown)).Select
    	Application.CutCopyMode = False
    	Selection.Copy
        Sheets("Hepsi").Select
    	Application.Goto Reference:="R1C1"
    	Selection.End(xlDown).Select
    	ActiveCell.Offset(1, 0).Select
	ActiveSheet.Paste

 

[inci55]

problemi çözdüm...

Sorunu çözdüm, belki başkalarına da faydası olur...

Sub Makro1()

    Sheets("Torbalama-2 S3M028").Select
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("Hepsi").Select
    ActiveSheet.Cells(1, 1).Select
    ActiveSheet.Paste
        
    Sheets("Torbalama-1 S3M027").Select
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("Hepsi").Select
    ActiveSheet.Cells(1, 1).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    
End Sub

 

[Emir Hüseyin Çoban]

. . .

Merhaba. Sorunuzu çözümenize sevindim.
Ancak küçük bir örnek dosya eklerseniz. Örneğin içerisinde bahsettiğiniz sayfalardan 9-10 tanesi olan ve içerisinde 5-6 satırlık veri olacak şekilde.

Daha hızlı ve sorunsuz çalışan bir kodlama yapılabilir.

. . .

 

[inci55]

dosya ekte

ekte örnek dosya vardır, belki faydalanmak isteyen olur.
kod da aşağıdadır.
Açıklama:
istenilen sayfalarda, ilk hücreden önce sağa sonra aşağıya doğru tüm verileri seçip başkabir sayfada altalta ekliyor.
Daha sonra başlık satırının 1 tane olması gerektiğinden en üstteki hariç diğer başlıkları siliyor.

Sub makro()

    Sheets("Hepsi").Activate
    Selection.ClearContents
    Sheets("S3M028").Activate
    ActiveSheet.Cells(1, 1).Select
    ActiveSheet.Range(Selection, Selection.End(xlToRight)).Select
    ActiveSheet.Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("Hepsi").Activate
    ActiveSheet.Cells(1, 1).Select
    ActiveSheet.Paste
       
    Sheets("S3M027").Activate
    ActiveSheet.Cells(1, 1).Select
    ActiveSheet.Range(Selection, Selection.End(xlToRight)).Select
    ActiveSheet.Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("Hepsi").Activate
    ActiveSheet.Cells(1, 1).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    
    Sheets("S3M019").Activate
    ActiveSheet.Cells(1, 1).Select
    ActiveSheet.Range(Selection, Selection.End(xlToRight)).Select
    ActiveSheet.Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("Hepsi").Activate
    ActiveSheet.Cells(1, 1).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
         
    x = 2
    
    Sheets("Hepsi").Activate
    With ActiveSheet
    
    Do
    If Mid(.Cells(x, 1), 1, 2) = "ÜN" Then
        .Rows(x).Select
        Selection.Delete Shift:=xlToRight
    Else
    x = x + 1
    If .Cells(x, 1) = "" Then
    firstnotempty = True
    End If
        
    End If
        
    Loop Until firstnotempty
    End With
    End Sub

 

[Emir Hüseyin Çoban]

. . .

Alternatif olsun.

. . .