Çalışma kitabındaki sayfaları birleştirmek

[Salihd46]

Hayırlı sabahlar arkadaşlar,
buraya sormadan biraz araştırdım bulamadım,
excel dosyasındaki sekmeleri tek bir sekmede nasıl birleştiririz, bi formül bulamadım, örnek ekteki dosya

 

[YUSUF44]

Birleştirmenin nasıl olması gerektiğini belirtseniz iyi olurdu. Başlangıç için aşağıdaki makroyu deneyin:

Sub sayfalar()

Sheets(1).Copy After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Range("A15:AR" & Rows.Count).ClearContents
For i = 1 To Sheets.Count
    If Sheets(i).Name <> Sheets(Sheets.Count).Name Then
        son = Sheets(i).Cells(Rows.Count, "E").End(3).Row
        yeni = WorksheetFunction.Max(15, Sheets(Sheets.Count).Cells(Rows.Count, "E").End(3).Row + 1)
        Sheets(i).Range("A15:AQ" & son).Copy Sheets(Sheets.Count).Cells(yeni, "A")
    End If
Next
End Sub

 

[Salihd46]

Yusuf bey çok teşekkür ederim, yardımınızla halloldu küçük çalışmam.
Amacım bu listelerdeki küpe numaralı hayvanlardan "Uygun" olanların küpe numaralarını almaktı bulunduğum excele.
Ben bu konuda biraz yeniyim, çok teorik bilgim yok ama elimden geldiği kadar araştırıyorum. Onun için ayrıntı vermedim ilk mesajda, o zaman ısmarlama kod oluyor manası hissedilme ihtimaline binaen, aradığım önemli kod parçası noktasında uzmanlara danışayım dedim.
Sizin yönlendirdiğiniz Amasya'nın tarım sitesindeki proğramdan da çok şey öğrendim.

Sizin de desteğinizle az önce bitirdim aklımdaki çalışmayı, altta veriyorum.
Bu, başka bir düşündüğüm çalışmanın önemli bir parçası idi, şimdi de çok işime yarayacak inş.

Sub UygunEkle()

Application.ScreenUpdating = False

        Dim strDocument, Dosyasonu, Kitapadi As String

    Kitapadi = Application.ActiveWorkbook.Name

    strDocument = Application.GetOpenFilename("xls Files,*.xls,All Files,*.*", 1, "Open File", , False)

    If Len(strDocument) < 6 Then Exit Sub

    Dosyasonu = Right(strDocument, Len(strDocument) - InStrRev(strDocument, "\"))

    ActiveWorkbook.FollowHyperlink strDocument

    Range("a1").Select

        If Range("M15").Value <> "MALATYA" Then

    MsgBox ("Lütfen doğru liste seçiniz..."), vbCritical, "Hatalı Liste..."

        Else

   Sheets(1).Copy After:=Sheets(Sheets.Count)

Sheets(Sheets.Count).Range("A15:AR" & Rows.Count).ClearContents

For i = 1 To Sheets.Count

    If Sheets(i).Name <> Sheets(Sheets.Count).Name Then

        son = Sheets(i).Cells(Rows.Count, "E").End(3).Row

        yeni = WorksheetFunction.Max(15, Sheets(Sheets.Count).Cells(Rows.Count, "E").End(3).Row + 1)

        Sheets(i).Range("A15:AQ" & son).Copy Sheets(Sheets.Count).Cells(yeni, "A")

  

End If

    Next

Cells.Select

Selection.UnMerge

Range("O18").Select

Columns("H:H").Select

Selection.Copy

Columns("AS:AS").Select

ActiveSheet.Paste

Columns("AE:AE").Select

Selection.Copy

Columns("AT:AT").Select

ActiveSheet.Paste

Range("A7").Select

Rows("15:6000").Select

Selection.RowHeight = 15

Selection.ColumnWidth = 15

Columns("A:AQ").Select

Range("AQ1").Activate

Selection.Delete

Range("A1").Select

Columns("B:C").Select

    Selection.AutoFilter

    ActiveSheet.Range("$B$1:$C$6000").AutoFilter Field:=2, Criteria1:="Uygun"

    Columns("B:B").Select

    Selection.Copy

    Sheets.Add After:=Sheets(Sheets.Count)

    Columns("A:A").Select

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

        :=False, Transpose:=False


    Columns("A:A").Select

    Selection.Copy

    Workbooks(Kitapadi).Activate

    Windows("Uygunlar.xlsx").Activate

    Columns("A:A").Select

    ActiveSheet.Paste

    Windows("İşletme_Raporu.xls").Activate

    Application.DisplayAlerts = False

    Workbooks(Dosyasonu).Close savechanges:=False

    Application.DisplayAlerts = True

    Windows("Uygunlar.xlsx").Activate

    Range("O6").Select

    Worksheets("Uygunlar").Visible = xlSheetVeryHidden

    MsgBox ("Uygun olan numaralar Başarıyla Yüklendi"), vbInformation

    Application.ScreenUpdating = True

    End If

  End Sub

 

[Salihd46]

Kodda ufak bir yanlış buldum düzelttim

Sub UygunEkle()

Application.ScreenUpdating = False

    Dim strDocument, Dosyasonu, Kitapadi As String
    Kitapadi = Application.ActiveWorkbook.Name
    strDocument = Application.GetOpenFilename("xls Files,*.xls,All Files,*.*", 1, "Open File", , False)
    If Len(strDocument) < 6 Then Exit Sub
    Dosyasonu = Right(strDocument, Len(strDocument) - InStrRev(strDocument, "\"))
    ActiveWorkbook.FollowHyperlink strDocument
    Range("a1").Select
        If Range("M15").Value <> "MALATYA" Then
    MsgBox ("Lütfen doğru liste seçiniz..."), vbCritical, "Hatalı Liste..."
        Else
   Sheets(1).Copy After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Range("A15:AR" & Rows.Count).ClearContents
For i = 1 To Sheets.Count
    If Sheets(i).Name <> Sheets(Sheets.Count).Name Then
        son = Sheets(i).Cells(Rows.Count, "E").End(3).Row
        yeni = WorksheetFunction.Max(15, Sheets(Sheets.Count).Cells(Rows.Count, "E").End(3).Row + 1)
        Sheets(i).Range("A15:AQ" & son).Copy Sheets(Sheets.Count).Cells(yeni, "A")
    End If
    Next
Cells.Select
Selection.UnMerge
Range("O18").Select
Columns("H:H").Select
Selection.Copy
Columns("AS:AS").Select
ActiveSheet.Paste
Columns("AE:AE").Select
Selection.Copy
Columns("AT:AT").Select
ActiveSheet.Paste
Range("A7").Select
Rows("15:6000").Select
Selection.RowHeight = 15
Selection.ColumnWidth = 15
Columns("A:AQ").Select
Range("AQ1").Activate
Selection.Delete
Range("A1").Select
Columns("B:C").Select
Selection.AutoFilter
ActiveSheet.Range("$B$1:$C$6000").AutoFilter Field:=2, Criteria1:="Uygun"
Columns("B:B").Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
Columns("A:A").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Columns("A:A").Select
Selection.Copy
Workbooks(Kitapadi).Activate
Windows("Uygunlar.xlsx").Activate
Columns("A:A").Select
ActiveSheet.Paste
Windows("İşletme_Raporu.xls").Activate
Application.DisplayAlerts = False
Workbooks(Dosyasonu).Close savechanges:=False
Application.DisplayAlerts = True
Windows("Uygunlar.xlsx").Activate
Range("O6").Select
Application.ScreenUpdating = True
MsgBox ("Uygun olan numaralar Başarıyla Yüklendi"), vbInformation
End If
End Sub