Böl-parçala-farklı kaydet

[mhmmdeniz]

21 tane şube mevcut.Konsolide gelen bilgileri şube şube ayırıp kaydedip o şekilde şubelere gönderiyoruz. Tek tek uğraşmak zaman alıyor.Tüm şube listesini şube adına göre bir kere de parçalayıp 1 kere de 21 adet excele kaydedebilmenin yolu var mı?

Şube koduna göre makro verebilecek var mı?
Şube kodları: 9,16,17,32,46,60,65 68,72,100,116,119,126,146,147,170,171,172,180,187, 204 toplam 21 şube

http://dosya.co/32ehu15mgw2z/ÖRNEK.XLSX.html

Örnekte sorumluluğumuzda bulunan 21 şubeye ait veriler tek seferde tarafımıza gönderilmektedir. Şube mahremiyeti nedeniyle her şubenin verisini parçalayıp farklı kaydederek diğer şubelerin görmemesi için ayrı ayrı mail atmaktayız.Bu verilerde değişmeyen tek şey şube kodları. O yüzden şube kodlarına göre kaç satır olursa olsun 21 şubeyi 21 ayrı excele kaydedebilmeyi umuyorum. Yoksa tek tek filtre çekip farklı kaydederek yapıyorum ve uzun sürüyor.

 

[alicimri]

Dosyaların kaydedileceği yeri kendinize göre düzeltin. Aşağıdaki kodlarda D'ye kaydediyor.

Sub aktar()
say = Sheets("CH BAKİYE").Range("A65536").End(3).Row
Dizi = "9,16,17,32,46,60,65,68,72,100,116,119,126,146,147,170,171,172,180,187,204"
Dizi = Split(Dizi, ",")
For i = 0 To 20
Sheets("CH BAKİYE").Columns("A:A").AutoFilter Field:=1, Criteria1:=CStr(Dizi(i))
Sheets.Add.Name = Dizi(i)
Sheets("CH BAKİYE").Range("A1:H" & say).Copy Sheets(Dizi(i)).Range("A1")
Sheets(Dizi(i)).Move
ActiveWorkbook.SaveAs "D:\" & Dizi(i)
ActiveWorkbook.Close
DoEvents
Next
End Sub

 

[mhmmdeniz]

Ali Bey öncelikle teşekkür ederim. İlgilenip vakit ayırmışsınız. Ortaya güzel bir şey çıkmış fakat kurum network olduğu için hedef klasörü desktopta yer alan herhangi bir dosyanın özelliklerinde bulunan konum bilgisini yapıştırmama rağmen masaüstüne düşmüyor. Dolayısı ile işleyişini henüz göremedim. Ayrıca eğer mümkünse 100 adet sütunu algılasın ve satır konusunda da 1000 satırı algılayabilsin. B sütunun da yazan ismi dosya ismi yaparak kaydetsin.
Mesela 9-Manisa şube diyelim. Manisa olarak dosyayı kaydetsin. Ve tüm dosyalar A3ten itibaren şekillensin ilk iki satır bana kalsın.

 

[mhmmdeniz]

Ali Bey son hali bu oldu.Hallettim bir kısmını elinize sağlık sağlam olmuş. Fakat save as için masaüstündeki herhangi bir klasör adını girdiğimizde oraya atmak yerine yine masaüstüne kaydediyor. Ayrıca bazı raporlarda raporu gelmeyen şubeler olabiliyor. Mesela 17 nolu şube yoksa makroda çalışmıyor.
Sub aktar()
say = Sheets("Sheet1").Range("A65536").End(3).Row
Dizi = "9,16,17,32,46,60,65,68,72,100,116,119,126,146,147,170,171,172,180,187,204"
Dizi = Split(Dizi, ",")
For i = 0 To 500
Sheets("Sheet1").Columns("A:A").AutoFilter Field:=1, Criteria1:=CStr(Dizi(i))
Sheets.Add.Name = Dizi(i)
Sheets("Sheet1").Range("A1:L" & say).Copy Sheets(Dizi(i)).Range("A1")
Sheets(Dizi(i)).Move
ActiveWorkbook.SaveAs Filename:="C:\Users\USR3048\Desktop\" & Range("B2").Value & ".xls"
ActiveWorkbook.Close
DoEvents
Next
End Sub

 

[alicimri]

Kırmızı yerler listede o şubenin olup olmadığını test ediyor. O şube yoksa hiç işlem yapmıyor. Mavi olan yere siz masa üstündeki klasör adını yazın.

Sub aktar()
say = Sheets("CH BAKİYE").Range("A65536").End(3).Row
Dizi = "9,16,17,32,46,60,65,68,72,100,116,119,126,146,147,170,171,172,180,187,204"
Dizi = Split(Dizi, ",")
For i = 0 To 20
[COLOR="Red"]If WorksheetFunction.CountIf(Sheets("CH BAKİYE").Columns("A:A"), CStr(Dizi(i))) > 0 Then[/COLOR]
Sheets("CH BAKİYE").Columns("A:A").AutoFilter Field:=1, Criteria1:=CStr(Dizi(i))
Sheets.Add.Name = Dizi(i)
Sheets("CH BAKİYE").Range("A1:H" & say).Copy Sheets(Dizi(i)).Range("A1")
Sheets(Dizi(i)).Move
ActiveWorkbook.SaveAs "C:\Users\USR3048\Desktop\[COLOR="Blue"]klasörAdı\[/COLOR]" & Range("B2").Value & ".xls"
ActiveWorkbook.Close
DoEvents
Sheets("CH BAKİYE").Columns("A:A").AutoFilter
[COLOR="red"]End If[/COLOR]
Next
End Sub