Exceli Dosyalara Parçalama

Katılım
13 Temmuz 2013
Mesajlar
241
Excel Vers. ve Dili
Türkçe 2007
Merhaba arkadaşlar,
A sütununda yer alan verilerin, inputbox a girdiğim degere göre dosyalara parcalamasini istiyorum.

Örneğin; A sütununda 10.500 adet veri var ise, inputbox'a 1.000 rakamini girdiğim de 11 ayri excel oluşturacak ve masaüstünde bir klasöre kaydedecek. Yardımlarınız için şimdiden teşekkür ederim...
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,757
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Merhaba
Bir çözümü belki bulunabilir şuan itibariyle 204 mesajınız olmuş demek ki baya kıdem almışsınız bu formda bir örnek dosya ekleseydiniz belki cevap veren birileri çıkardı.

Kod:
Sub CommandButton42_Click()

Dim oExcel As Object
Dim oBook As Object
Dim oSheet1 As Object
Dim oSheet3 As Object
Dim oSheet2 As Object
bas = Application.InputBox("Başlangıç tarihini AY olarak giriniz.", "Sayfa sayısı " & sayfa_sayisi, "2", 400, 30, , Type:=1)
atla1:
If bas = False Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If

If bas <= 0 Then
MsgBox " baslangıc sıfırdan büyük sayı giriniz"
GoTo atla1
Exit Sub
End If

sayf1 = "Sayfa1"
son = Worksheets(sayf1).Cells(Rows.Count, "A").End(3).Row
If bas > son Then
sat = son
Else
sat = bas
End If

For r = 1 To son Step sat
MsgBox r & Chr(10) & r + sat - 1
Range("A" & r & ":D" & r + sat - 1).Copy

Set oExcel = CreateObject("Excel.Application")
Set oBook = oExcel.Workbooks.Add

Set oSheet1 = oBook.Worksheets(1)
Set oSheet3 = oBook.Worksheets(3)
Set oSheet2 = oBook.Worksheets(2)

oSheet3.Delete
oSheet2.Delete
oSheet1.Name = "data"
oSheet1.Range("a1").Select
oSheet1.Paste
oSheet1.Range("a1").Select
Application.CutCopyMode = False
 
klasor = ThisWorkbook.Path
yer = "Rapor " & CreateObject("Scripting.FileSystemObject").getfolder(klasor).Files.Count + 1
oBook.SaveAs (ThisWorkbook.Path & "\" & yer & ".xls")
oExcel.Quit
Next r
MsgBox "işlem tamam"

End Sub
 
Son düzenleme:
Üst