Sayfadaki verileri belirli adette bölme

[kanarya_83]

Merhaba,

94148 satırlık bir excel dosyasını baştaki satır her çalışma kitabında sabit kalacak şekilde 2000 satırlık parçalar halinde bölmek istiyorum.

Her kitapta yenilenecek başlıklar şunlardır:

A1:TITLE
B1:WRITER
C1ERFORMER
D1:COSIS WORK NUMBER
E1:MUSIC DURATION
F1:USAGES
G1:AMOUNT
H1ERFDATE
I1ERFTIME
J1FACTOR
K1:SOURCE

Bu konuda yardımızı rica ediyorum.

Teşekkürler

 

[ÖmerBey]

Merhaba,
Aşağıdaki kodu deneyiniz. (Verilerinizin 2. satırdan başladığı varsayılmıştır.)

Sub Kod()
Set w1 = ThisWorkbook
Set s1 = ThisWorkbook.ActiveSheet
Application.ScreenUpdating = False
başlık = Array("TITLE", "WRITER", "PERFORMER", "COSIS WORK NUMBER", "MUSIC DURATION", "USAGES", "AMOUNT", "PERFDATE", "PERFTIME", "PFACTOR", "SOURCE")
For a = [COLOR="Red"]2 [/COLOR]To s1.Range("A" & Rows.Count).End(3).Row Step 2000
    say = say + 1
    Set w2 = Workbooks.Add
    Set s2 = w2.Sheets(1)
    s2.Range("A1:K1") = başlık
    Range(s1.Cells(a, "A"), s1.Cells(a + 1999, "K")).Copy s2.Range("A2")
    w2.SaveAs Filename:=w1.Path & "\" & w1.Name & " - Parça " & say & ".xlsx", _
            FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    w2.Close 1
Next
Application.ScreenUpdating = True
End Sub

 

[kanarya_83]

Merhaba,
Aşağıdaki kodu deneyiniz. (Verilerinizin 2. satırdan başladığı varsayılmıştır.)

Sub Kod()
Set w1 = ThisWorkbook
Set s1 = ThisWorkbook.ActiveSheet
Application.ScreenUpdating = False
başlık = Array("TITLE", "WRITER", "PERFORMER", "COSIS WORK NUMBER", "MUSIC DURATION", "USAGES", "AMOUNT", "PERFDATE", "PERFTIME", "PFACTOR", "SOURCE")
For a = [COLOR="Red"]2 [/COLOR]To s1.Range("A" & Rows.Count).End(3).Row Step 2000
    say = say + 1
    Set w2 = Workbooks.Add
    Set s2 = w2.Sheets(1)
    s2.Range("A1:K1") = başlık
    Range(s1.Cells(a, "A"), s1.Cells(a + 1999, "K")).Copy s2.Range("A2")
    w2.SaveAs Filename:=w1.Path & "\" & w1.Name & " - Parça " & say & ".xlsx", _
            FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    w2.Close 1
Next
Application.ScreenUpdating = True
End Sub

Çok teşekkür ederim. İnanılmaz faydalı oldu.