Sayfalara Ayır

Katılım
3 Ocak 2019
Mesajlar
8
Excel Vers. ve Dili
Excel 2016 - İngilizce
Herkese merhaba,

Öncelikle geçmişteki benzer yazıları araştırdım lakin kendi excelime uygulama konusundaki tecrübem yetersiz kaldı.

10.000 Satırlık bir çalışma var ve ilk etapta hepsini sayfa sayfa ayrıştırıp o sayfalarda tek tek işlem yapıp en sonunda yeniden tek sayfada birleştirmek istiyorum.

Sizden A sütununda bulunan benzer isimli satırları sayfalara ayırmak ve en sonunda da bunları birleştirmek adına destek rica ediyorum.

http://s7.dosya.tc/server12/b953cu/SAYFA_AYIR.xlsx.html

Şimdiden desteğiniz için teşekkür ederim.
 

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,553
Excel Vers. ve Dili
Pro Plus 2021
Kod:
Sub sayfalaraBol()
    Application.DisplayAlerts = False

    ReDim sayfalar(1 To Sheets.Count)

    For i = 1 To Sheets.Count
        sayfalar(i) = Sheets(i).Name
    Next i

    Sheets("Sheet1").Copy After:=Sheets(Sheets.Count)
    Set s2 = ActiveSheet

    Do
        shf = s2.Range("a1")
        If Not IsError(Application.Match(shf, sayfalar, 0)) Then Sheets(shf).Delete

        s2.Copy After:=Sheets(Sheets.Count)
        Set s3 = ActiveSheet
        s3.Name = shf

        For i = Sheets.Count - 1 To 2 Step -1
            If Sheets(i).Name > shf Then
                s3.Move before:=Sheets(i)
            End If
        Next i

        For i = 1 To Cells(Rows.Count, 1).End(3).Row
            If Cells(i, 1).Value <> shf Then Cells(i, 1).ClearContents
        Next i
        [a:a].SpecialCells(xlCellTypeBlanks).EntireRow.Delete

        For i = 1 To s2.Cells(Rows.Count, 1).End(3).Row
            If s2.Cells(i, 1).Value = shf Then s2.Cells(i, 1).ClearContents
        Next i
        s2.[a:a].SpecialCells(xlCellTypeBlanks).EntireRow.Delete

    Loop Until s2.Range("a1") = ""

    s2.Delete

    Application.DisplayAlerts = True
End Sub
 

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,553
Excel Vers. ve Dili
Pro Plus 2021
Bu da ayrılan sayfaları sıralamaları ve düzeni bozmazsanız aynı sırayla 2nci sayfada birlestirir. İlk sayfanız eski haliyle kalır.
Kod:
Sub sayfalariBirlestir()
    Application.DisplayAlerts = False

    For i = 1 To Sheets.Count
        If Sheets(i).Name = "Hepsi" Then
            Sheets("Hepsi").Delete
            Exit For
        End If
    Next i

    Set S2 = Sheets(2)
    S2.Name = "Hepsi"

    For i = 3 To Sheets.Count
        Sheets(i).UsedRange.Cut S2.Cells(Rows.Count, 1).End(3).Offset(1)
    Next i

    For i = Sheets.Count To 3 Step -1
        Sheets(i).Delete
    Next i

    Application.DisplayAlerts = True
End Sub
 

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,553
Excel Vers. ve Dili
Pro Plus 2021
Bu da seçilmiş sayfaları Birlesim sayfasında birlestirir ve seçili sayfaları siler.
Kod:
Sub seciliSayfalariBirlestir()
    Application.DisplayAlerts = False

    For Each sh In Sheets
        If sh.Name = "Birlesim" Then
            sh.Delete
            Exit For
        End If
    Next

    a = 1
    For Each sh In ThisWorkbook.Windows(1).SelectedSheets
        If a > 1 Then
            sh.UsedRange.Cut s2.Cells(Rows.Count, 1).End(3).Offset(1)
            sh.Delete
        Else
            Set s2 = sh
            s2.Name = "Birlesim"
        End If
        a = a + 1
    Next

    Application.DisplayAlerts = True
End Sub
 
Üst