Merhabalar,
Excel makrolarında yeniyim. Şöyle bir ihtiyacım vardı. Elimde A'dan P'ye sutun, 20000 satırlı bir excel dosyası var.
1. satırda sütünların başlığı var. Ad, id, link vs.. gibi.
Amacım bu datayı ilk satır hepsinde aynı olmak üzere 50 satır halinde bölerek yeni dosyalar kaydetmek.
Bu çalışmaya çok ihtiyacım var ama bir türlü çözüm üretemedim. Forumda şöyle bir koda denk geldim fakat çalıştıramadım hata yapıyorum sanırım.
Excel makrolarında yeniyim. Şöyle bir ihtiyacım vardı. Elimde A'dan P'ye sutun, 20000 satırlı bir excel dosyası var.
1. satırda sütünların başlığı var. Ad, id, link vs.. gibi.
Amacım bu datayı ilk satır hepsinde aynı olmak üzere 50 satır halinde bölerek yeni dosyalar kaydetmek.
Bu çalışmaya çok ihtiyacım var ama bir türlü çözüm üretemedim. Forumda şöyle bir koda denk geldim fakat çalıştıramadım hata yapıyorum sanırım.
Kod:
Sub Baska_Dosyaya_Yaz()
Dim i As Long
Dim j As Integer
Dim SonKol As Integer
Dim Yol As String
Dim Dosya_Ad As String
Dim SatirAdedi As Integer
Yol = ThisWorkbook.Path & Application.PathSeparator
SatirAdedi = 10
Application.ScreenUpdating = False
SonKol = [IV1].End(1).Column
For i = 2 To [A65536].End(3).Row Step SatirAdedi
j = j + 1
Dosya_Ad = "Dosya-" & j
Set NewBook = Workbooks.Add
With NewBook
.Title = "www.excel.web.tr Tarafından Programatik Olarak Oluşturuldu"
.Subject = "Dosya Bölme"
.SaveAs Filename:=Yol & Dosya_Ad & ".xls"
End With
ActiveWorkbook.Close True
Workbooks.Open Filename:=Yol & Dosya_Ad & ".xls"
Windows("DOSYA_AYIR.xls").Activate
Range(Cells(1, "A"), Cells(1, SonKol)).Select
Selection.Copy
Windows(Dosya_Ad & ".xls").Activate
Sheets(1).Range("A1").Select
ActiveSheet.Paste
Windows("DOSYA_AYIR.xls").Activate
Range(Cells(i, "A"), Cells(i + SatirAdedi - 1, SonKol)).Select
Selection.Copy
Windows(Dosya_Ad & ".xls").Activate
Sheets(1).Range("A2").Select
ActiveSheet.Paste
[A1].Select
ActiveWorkbook.Close True
Application.CutCopyMode = False
Next i
[A1].Select
MsgBox "Aktarım İşlemi Bitmiştir..........."
End Sub