Bölerek kaydetme

[Biray3550]

Merhaba,
150.000 Kayıtlı dosyayı Elli Bin, Elli Bin masa üzerindeki dosya ismindeki klasöre XLS uzantılı kaydetmesini, Kaydedilecek sayfanın adını da Stok olarak düzenleyecek, Her böldüğü sayfanın başına ilk sayfanın başlıkları gelecek ve sadece hücre değerini kopyalayacak macro lazım.
Yardımcı olabilir misiniz?
Teşekkür ederim.

 

[ÖmerBey]

Merhaba,
Deneyiniz...

Sub kod()
Dim s1 As Worksheet
Dim w1 As Workbook
Dim a As Long
Dim sat As Long
Dim b As Byte
Dim yol As String

sat = 50000 'Ayırmak istediğiniz veri adeti
Set s1 = ActiveSheet
bslk = s1.Range("A2:H2").Value
yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\dosya\" 'Dosyaları kaydetmek istediğiniz klasör yolu

Application.ScreenUpdating = False
For a = 3 To s1.Cells(s1.Rows.Count, "H").End(3).Row Step sat
    dz = s1.Range(s1.Cells(a, "A"), s1.Cells(a + sat - 1, "H")).Value
    Set w1 = Workbooks.Add
    With w1.Sheets(1)
        .Range("A1").Resize(1, UBound(bslk, 2)).Value = bslk
        .Range("A2").Resize(UBound(dz), UBound(dz, 2)).Value = dz
        .Columns("A:H").AutoFit
    End With
    b = b + 1
    w1.SaveAs Filename:=yol & "Stok" & b & ".xls", FileFormat:=xlExcel8
    w1.Close 0
Next
Application.ScreenUpdating = True
MsgBox "İşlem tamam"
End Sub

 

[Biray3550]

Çok teşekkür ederim. Elinize sağlık.

 

[ÖmerBey]

Rica ederim,
İyi çalışmalar...