Dosya parçalama

[karacakamil]

Ekte örnek dosya yükledim. Dosya içinde "parçalanacaklar" klasöründeki dosyaları "b" sütunundaki ilçe isimlerine göre parçalama yapacak
-"b" sütunundaki ilçe isimleri kadar klasör oluşturacak
-bu yeni klasörlere parçalama yapılacak dosyaları koyacak ama;
**ilk 5 sıradaki iller (öğrenci adetleri hariç) kalacak
**içinde bulunduğu il adı hangi satırda ise o satır da kalacak
**diğer tüm veriler silinecek.

Anlatınca biraz karmaşık gözüküyor ama
ekteki dosyalar incelendiğinde daha iyi anlaşılacaktır.

şimdiden desteğiniz için teşekkür ederim.

EK LİNK:
http://s5.dosya.tc/server5/ng6ck5/PARCALAMA_PROGRAMI.rar.html

DÜZELTME: "PARÇALANDIĞINDA BEKLENEN DOSYALAR" klasöründeki ""BEYKOZ" klasörünün ismi "AVCILAR" olacak. yanlışlık olmuş

 

[karacakamil]

yardım lazım....

 

[karacakamil]

yardım lazım....

 

[karacakamil]

yardım lazım.... kimye yok mu?

 

[Korhan Ayhan]

Merhaba,

Bu işlem için bir sayfada il ve ait olan ilçelerin isim listesi olması gerekir.

 

[PLİNT]

Merhaba
Ek dosyayı denermisiniz?
http://www.excel.web.tr/f48/tek-dosyadaki-bilglieri-kurum-kurum-ayyryp-kaydetme-t162018.html
Bu konunuzdaki dosya isteğinizin benzeri gibi görünüyor ama;
parçalanacak dosyaların 2. sayfalarında 1. sayfadan fazla ilçe ismi varsa hata verebilir.
Eğer öyle bir durum ortaya çıkarsa Sn.Korhan beyin belirttiği gibi "Parçalayıcı.xlsm" dosyasına ilçe isim listesi eklemelisiniz.

http://s5.dosya.tc/server5/eb1ug5/PARCALAMA_PROGRAMI.zip.html

[SIZE="2"]Private Sub CommandButton1_Click()
a = "PARÇALANACAKLAR"
b = "PARÇALANANLAR"
Set c = CreateObject("Scripting.FileSystemObject")
yol = ThisWorkbook.Path
If c.FolderExists(yol & "\" & b) = False Then c.CreateFolder yol & "\" & b
For tekrar = 1 To 2
Set Aç = New Excel.Application
okul = IIf(okul = "LİSE", "ORTAOKUL", "LİSE")
Dosya = yol & "\" & a & "\" & okul & ".xlsx"
Aç.Workbooks.Open Dosya
Set hz = Aç.Workbooks(Dir(Dosya))
For Each syf In hz.Sheets
If hz.Sheets(syf.Name).Range("A1").Value Like "*" & "DENEME NETİCE" & "*" Then
i = hz.Sheets(syf.Name).Cells(Rows.Count, "B").End(3).Row
[COLOR="Red"]For sat = 5 To i - 1[/COLOR]
If Trim(hz.Sheets(syf.Name).Cells(sat, "B")) = "" Then Exit For
ilçe = Trim(hz.Sheets(syf.Name).Cells(sat, "B").Value)
If c.FolderExists(yol & "\" & b & "\" & ilçe) = False Then c.CreateFolder yol & "\" & b & "\" & ilçe
If c.FileExists(yol & "\" & b & "\" & ilçe & "\" & okul & ".xlsx") = False Then
hz.Sheets.Copy
Set hz2 = Aç.Workbooks(2)
For Each syf2 In hz2.Sheets
i2 = hz2.Sheets(syf2.Name).Cells(Rows.Count, "B").End(3).Row - 1
For sat2 = 10 To i2
If Trim(hz2.Sheets(syf2.Name).Cells(sat2, "B")) <> ilçe Then
hz2.Sheets(syf2.Name).Range("B" & sat2 & ":J" & sat2) = Empty
End If
Next:
[COLOR="red"]If sat < 10 Then
For t = 5 To 9
If Trim(hz2.Sheets(syf2.Name).Range("B" & t).Value) <> ilçe Then _
hz2.Sheets(syf2.Name).Range("C" & t & ":D" & t) = Empty
Next
Else
hz2.Sheets(syf2.Name).Range("C5:D9") = Empty
End If[/COLOR]
hz2.Sheets(syf2.Name).Range("B" & i2 + 1 & ":J" & i2 + 1) = Empty
Next
adr = yol & "\" & b & "\" & ilçe & "\" & okul & "A" & ".xlsx"
If Not c.FileExists(adr) Then hz2.SaveAs adr
hz2.Close SaveChanges:=False
Name adr As yol & "\" & b & "\" & ilçe & "\" & okul & ".xlsx"
ff = ff + 1
Cells(ff, 1) = b & "\" & ilçe & "\" & okul & ".xlsx"
End If
Next
End If
Next
hz.Close SaveChanges:=False
Aç.Quit
Set Aç = Nothing: Set hz = Nothing
Next
End Sub
 [/SIZE]

 

[karacakamil]

çok teşekkür ederim. Olmuş ama

hangi ilçe ise o ilcenin dşındaki ilk beş ilçenin öğrenci sayıları da sininsin
en alttaki ortalamalar da silinsin

parametrelerini de ekleyebilir miyiz.

 

[karacakamil]

RESİMDEKİ SARI ALANLAR DA SİLİNECEK ŞEKİLDE BİR DÜZELTME YAPABİLİR MİYİZ?
TEŞEKKÜR EDERİM


EKTE LİNKTE OLDUĞU GİBİ

http://s8.dosya.tc/server5/2qrl2c/Adsiz.jpg.html

 

[PLİNT]

RESİMDEKİ SARI ALANLAR DA SİLİNECEK ŞEKİLDE BİR DÜZELTME YAPABİLİR MİYİZ?
TEŞEKKÜR EDERİM

Merhaba
Yukarıdaki değişen dosya ve kodları deneyelim.

 

[karacakamil]

Teşekkür ederim lakin son anda farkettim ki İlk 5 ilçeyi parçalamaya koymamış.
İlk 5 ilçeyi de parçalayıp diğer kalan dört tanesinin talebe adetlerini silecek şekilde tekrar bir düzeltme yapabilir miyiz?

 

[PLİNT]

Teşekkür ederim lakin son anda farkettim ki İlk 5 ilçeyi parçalamaya koymamış.
İlk 5 ilçeyi de parçalayıp diğer kalan dört tanesinin talebe adetlerini silecek şekilde tekrar bir düzeltme yapabilir miyiz?

Merhaba
6 nolu mesajdaki kodları; eklenen ve düzeltilen şekliyle deneyin

 

[karacakamil]

Son birşey daha.

Parçalanacaklar dosyaları örnek dosyalardı.

Asıl kullanacağım dosların isimleri farklı.
Parçalanacaklar klasöründe olan "tüm excel dosyalarını" parçalayacak şekilde düzeltebilir miyiz?

 

[PLİNT]

Son birşey daha.
Parçalanacaklar dosyaları örnek dosyalardı.
Asıl kullanacağım dosların isimleri farklı.
Parçalanacaklar klasöründe olan "tüm excel dosyalarını" parçalayacak şekilde düzeltebilir miyiz?

Kodlardaki mavi bölümlerle belirtilen aralıkta; kırmızı değişiklikleri yaparak deneyin.

[SIZE="2"]Private Sub CommandButton1_Click()
a = "PARÇALANACAKLAR"
b = "PARÇALANANLAR"
Set c = CreateObject("Scripting.FileSystemObject")
yol = ThisWorkbook.Path
[COLOR="blue"]If c.FolderExists(yol & "\" & b) = False Then c.CreateFolder yol & "\" & b[/COLOR]
[COLOR="red"]Set n = c.GetFolder(yol & "\" & a)
Set dc = n.Files
For Each DOSYA In dc
If c.GetExtensionName(DOSYA) Like "xls" & "*" Then
Set Aç = New Excel.Application
okul = c.GetBaseName(DOSYA)[/COLOR]
[COLOR="Blue"]Aç.Workbooks.Open DOSYA[/COLOR]
Set hz = Aç.Workbooks(Dir(DOSYA))

     '...
    '....diğer kodlar
     '...............
     '....................

Cells(ff, 1) = b & "\" & ilçe & "\" & okul & ".xlsx"
End If
Next
End If
Next
hz.Close SaveChanges:=False
Aç.Quit
[COLOR="blue"]Set Aç = Nothing: Set hz = Nothing[/COLOR]
[COLOR="Red"]End If[/COLOR]
Next[COLOR="blue"]
[/COLOR]End Sub
 [/SIZE]

 

[karacakamil]

Ellerine sağlık. Teşekkür ederim.

Allah razı olsun.

Tam istediğim gibi oldu

 

[karacakamil]

Teşekkür ederim.