Soru BİRDEN ÇOK SATIRI BAŞLIĞI İLE BİRLİKTE AYRI SAYFALARA AYIRMA

[Uguruluocak]

Herkese selamlar;

Binlerce satırlık bir excel dosyam var. 130'lu olarak başlığı ile birlikte, aynı excel dosyası altında farklı çalışma sayfalarına bölmek istiyorum. Mümkün müdür? evetse nasıl?


örnek dosya

 

[tahsinanarat]

Sub SplitDataToMultipleSheets()

Dim LastRow As Long, n As Long, CntRows As Long
Dim LastColumn As Integer
baslangic = Now

CntRows = CInt(Sheets("Yonetici").TextBox1.Value) 'Boş bir sekme ekleyin bir buton ve TextBox1 ekleyin ayırmak istediğiniz satır sayısını buraya yazacaksınız. Eklediğiniz butona bu kodu atayınız.

Application.ScreenUpdating = False

With Sheets("Arsiv") 'Ayrılacak olan data sayfanız
    
    LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
    LastColumn = .Range("A1").SpecialCells(xlCellTypeLastCell).Column
    
    For n = 1 To LastRow Step CntRows
        

        Sheets.Add after:=Sheets(Sheets.Count)
        .Range("A" & n).Resize(CntRows, LastColumn).Copy Range("A1")
    Next n
    
    .Activate
End With

Application.ScreenUpdating = True
MsgBox "Süre : " & Format(Now - baslangic, "hh:mm:ss") & vbLf & _
"Ayirma isleminiz tamamlandı" & vbLf & "Tahsin ANARAT", vbOKOnly + vbInformation

End Sub

Test edildi 145500 satırı 130 luk satırlara 21 saniyede ayırdı.

Kolay Gelsin

 

[Uguruluocak]

Valla nedense olmadı, sizden ricam kodların içine tarif değil de hazır şablon yapabilir misiniz, sırasıyla ve başlığı ile 130 ar olarak ayrıştıran?

 

[tahsinanarat]

Sayfalara_Ayir2.xlsm dosyasını indir - download

Sayfalara_Ayir2.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s6.dosya.tc

 

[mühendisberke]

başlangıç sayfasının ismini kopya yap.
ayrılan sayfaların ismi direk sayı olacak(1 ya da 2 gibi)
100 taneye kadar bölüme ayırıyor.
Eğer biterse yeni sayfa açmadan duruyor
43 sayfaya böldü

Sub parcalabol()

Dim sayac1 As Long
Dim sayac2 As Long
Dim sheet_name As String
Dim boskontrol As String

For sayac1 = 1 To 100 Step 1
Worksheets.Add().Name = sayac1
Sheets("kopya").Select
Rows("1:1").Select
Selection.Copy
Sheets(sayac1).Select
Rows("1:1").Select
ActiveSheet.paste
Application.CutCopyMode = False
For sayac2 = 2 To 130 Step 1
Sheets("kopya").Select
Rows("2:2").Select
Selection.Copy
Sheets(sayac1).Select
Rows(sayac2).Select
ActiveSheet.paste
Application.CutCopyMode = False
Sheets("kopya").Select
Rows("2:2").Select
Selection.Delete Shift:=xlToUp
Next
boskontrol = Worksheets("kopya").Range("a2")
If boskontrol = "" Then Exit Sub
Next
End Sub

 

[Uguruluocak]

Sayfalara_Ayir2.xlsm dosyasını indir - download

Sayfalara_Ayir2.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s6.dosya.tc

Sen nası bi kralsın söyle nasıl, ömrümden zayi olan büyük bir zamanı geri kazandırdın Allah senden razı olsun <3

 

[mühendisberke]

Rica ederim. Bana da pratik oldu.
Domates gibi kızardım sağolun

 

[tahsinanarat]

Arkadaşlar gerçek uygulamada gördümki her sayfadan bir satır eksik çıktığını fark etmem üzerine başlıklarıyla birlikte eşit olarak dağıtımını yapan dosyayı tekrar ekliyorum.

Sn. @Uguruluocak bilginiz olsun.