Departmana Göre Sayfa Sayfa sıralatıp istemediğim sütünları otomotik silme ve her zam

[okan26]

Saygıdeğer Arkadaşlar Benim Problemim şu ;Ayda bir kez yapmam gereken bir listem var ve beni çok uğraştırıyor.Ben gördüğünüz gibi bayramda işimi yetiştirmek için çalışmak zorunda kalıyorum.
Bana yardımcı olursanız çok sevinirim.
Ekte gönderdiğim gibi bir listem var ve bu diyelimki 4000 satır , her ay bunun üstüne ben yeni gelen listemi yapıştırıp şu işlemleri yapmak istiyorum.
1-Listeyi yapıştırıp makroyu çalıştırınca Ana listem kalmak koşulu ile Kırmızı ile işaretlediğim sütünlar silinsin.

2-Başlık isimlerinde Departman yazan kısma göre otomotik olarak sadece o departmanı alarak alttaki sayfa1 e Diğer departmanı sayfa2 ye kopyalasın ve böyle departmanları sayfa sayfa ayırsın 50 departman yazdım
3-Sütünların en sonunda bulunan Gün ve açıklama kısmı normalde bana gelen listede yok ve bunları departmanları sayfa sayfa kopyalarkende oluştursun
4-Listedeki eleman sayısı her ay artıp eksilebileceğinden hata yapmaması gerekiyor.Yani verileri Özel yapıştırıp bunu sürekli kullanmak istiyorum
5-Ve zor bir işlem daha (En azından ilerde ihtiyaç duyarsam bu alttaki sayfaları tek ana sayfada birleştirebilirmiyim.

6-Excel e yabancı olduğum için bide Allah rızas için Acaba index Sayfası gibi birşey oluşturulabilirmi. Alttaki sayfalar arası geçiş çok zaman alıyor ve uğraştırıyor.

5-Bu benim işimi yıllarca görebileceği için 4000 Satır olduğu varsayılırsa çok memnun olurum.

 

[okan26]

Yokmu kimse Bayramda çalışmak isteyen..
Lütfen yapabilecek biri varsa yardımcı olsun..

 

[N.Ziya Hiçdurmaz]

yanıt

Birşeyler yapmaya çalıştım.
sayfalara ulaşmak için

Private Sub ListBox1_Click()
Sheets(ListBox1.Text).Select
End Sub
Private Sub UserForm_Initialize()
For i = 1 To Sheets.Count
ListBox1.AddItem Sheets(i).Name
Next
End Sub

Sütun silme ve sayfalara veri aktarma

Sub aktar()
For si = 2 To Sheets.Count
Sheets(si).Range("a2:x1000").Clear
Next
Range("H:N,P:P,R:X").Delete
For sut = 2 To [f65536].End(3).Row
For i = 2 To Sheets.Count
If Sheets(i).Name = Sheets("Ana Sayfa").Range("f" & sut) Then
Sheets("Ana Sayfa").Range("a" & sut & ":k" & sut).Copy
s = Sheets(i).[a65536].End(3).Row
Sheets(i).Range("a" & s + 1).PasteSpecial
End If: Next: Next
Application.CutCopyMode = False
End Sub

 

[okan26]

%50 tamam

üstadım % 50 si tamam... Silme işlemini yaptıda istediğim bilgileri departmanları sayfalara atamadım... vaktin olursa bakabilirsen sevinirim.
ilgine çok teşekkürler..

 

[N.Ziya Hiçdurmaz]

Eklediğim dosyanızı çalıştırdıysanız ilgili sütunları sildikten sonra şehirlere ait bilgileri ilgili sayfalara atmaktadır.istediğiniz bilgi aralığı nedir.

 

[okan26]

Öncelikle şunu hatırlatayım excel fazla bilmiyorum. Acaba benim sorunum 2003 türkçe kullanıyorum.ondan olabilirmi ?

modül ekleyip yapıştırdım kaydedip çalıştırdım.İşlem yapıyor ama ilgili şehir ( departmanlar ) atılmıyor..

 

[N.Ziya Hiçdurmaz]

Hücredeki şehir isimleri ile sayfa isimleri aynı olmalı.

 

[okan26]

Departman tek sabit değil

Benim Departman isimlerim Sabit değil.. Yani benim istediğim şu

Adana BM\Adana Misis Şube
Adana BM\Kozan Şube

gibi isimler olduğu için Adana Gördüğü yerleri Birinci sayfaya

İst-Mecidiyeköy BM\Cendere Şube
İst-Mecidiyeköy BM\Şişli Şube gibi isimlerden oluşan departmanlarda ilk BM yazan yere kadar olan şubeleri (departmanları) ayrı ayrı sayfalara atsın..
sorunumu tam anlatamamışım şimdi anladım :yardim:

 

[okan26]

Kısaca BM yazan yere kadar

Adana BM\Kozan Şube
İst-Mecidiyeköy BM\Şişli Şube
Adana BM\Misis Şube vb...



Kısaca BM Yazan yere kadar aynı olan şubelerimi ayrı ayrı sayfalara ayırsın..

 

[okan26]

Yüzdük yüzdük kuyruguna geldik yokmu benim şu işime el atan

 

[N.Ziya Hiçdurmaz]

yanıt

Anladığım kadarı ile her şehir için otomatik bir sayfa açıp o şehirlere ait bilgiler ilgili sayfalara aktarılmaktadır.(Eğer yine olmadı derseniz diğer arkadaşlarda bir göz atsınlar.)

Sub aktar()
On Error Resume Next
For i = 2 To Sheets.Count
Sheets(i).Select
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Next
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
For sut = [G65536].End(3).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("G2:G" & sut), Range("G" & sut)) = 1 Then
Range("G" & sut).Copy
s = s + 1
Range("A" & s).PasteSpecial
d = [a65536].End(3).Row
Range("A" & d + 1) = 1
End If
Next
For Each c In Range("A1:A" & [a65536].End(3).Row)
Set ekle = Sheets.Add
ekle.Move After:=Sheets(Sheets.Count)
On Error GoTo hata
ekle.Name = c
Next
hata:
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
Sheets("Ana Sayfa").Select
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
'**********************
For si = 2 To Sheets.Count
Sheets(si).Range("a2:x1000").Clear
Next
Range("H:N,P:P,R:X").Delete
For sut = 2 To [F65536].End(3).Row
For i = 2 To Sheets.Count
If Sheets(i).Name = Sheets("Ana Sayfa").Range("f" & sut) Then
Sheets("Ana Sayfa").Range("a" & sut & ":k" & sut).Copy
s = Sheets(i).[a65536].End(3).Row
Sheets(i).Range("a" & s + 1).PasteSpecial
Sheets("Ana Sayfa").Range("a1:k1").Copy
Sheets(i).Range("a1").PasteSpecial
End If: Next: Next
Application.CutCopyMode = False
End Sub

 

[okan26]

üstad emeğine yüreğine sağlık,
tam benim istediklerim olmadı ama yaptığın çalışmalar çok işime yaradı inşallah daha sonra bu konuyu bir daha açar şu departman meselesini o zaman hallederiz..

Saygılar..

 

[Korhan Ayhan]

Selamlar,

Alternatif olarak ekteki örnek dosyayı incelermisiniz.

Makroyu Ctrl+Shift+A tuşlarına basarak çalıştırabilirsiniz.
Dosyayı açtığınızda Yardım menüsünün yanına yeni bir menü eklenecektir. Bu menü yardımı ile istediğiniz sayfayı kolayca açabilirsiniz. Eğer menü kaybolursa yada yenilemek gerekirse F12 tuşuna basmanız yeterli olacaktır. Umarım faydası olur.

 

[okan26]

Çalıştı çok mutluyum.. mümkünse bitirelim

Sonunda dosya çalıştı ben sorunumu size tam anlatamadığımdan dolayı siz gönderdiğim dosyayı size gelen şekliyle yapmışsınız ve o şekilde makroyu çalıştırınca çalışıyor.. Şuan benim işimi tam görmedi ( Nankörlük etmeyelim %70 gördü ) ama çalıştığını görmek bana büyük bir haz verdi.. Karar verdim bunu bitirmek lazım yardımcı olmaya devam ederseniz çok mutlu olacağım..

1- Dosyam ekte Sadece Departman isimlerini bu sefer doğru yazdım.Yani Uzun şekliyle Örnek; Daha önce Sadece Adana yazmıştm Ama doğrusu
Adana BM\Adana Merkez olacaktı vb. Saatlerce kopyala yapıştır yaptım ama buna dikkat etmemiştim.Ben hep Adana BM\Adana Merkez yapıştırıyordum.Ama Size gönderdiğim şekliyle Sadece Adana yazınca dosya çalışıyor.. Bunu bu şekilde düzeltmenizi istirham edecektim..

2-Kırmızı olarak işaretli yerleri otomotik silsin istiyordum.Önceki dosyamda çalıştı ve işe yarıyor.Ama o kodu son excel dosyama ekleyemedim ALT-F11 Yapıp yapıştır kaydet yapıyorum ama makro görünmüyor. Daha önce gönderdiğiniz aşağıdaki kodu bu sayfaya ekleyebilirmisiniz. :roll:

Private Sub ListBox1_Click()
Sheets(ListBox1.Text).Select
End Sub
Private Sub UserForm_Initialize()
For i = 1 To Sheets.Count
ListBox1.AddItem Sheets(i).Name
Next
End Sub

3-Form çok güzel olmuş. Şu an aşağıda sayfa ekleyince direkt kendiliğinden ekleniyor.Bu şekilde devam ederse iyi olur..

Saygılarımla...

 

[okan26]

Sn: COST_CONTROL

Gönderdiğiniz örnek dosya çok güzel ve çoook hızlı Alanso gibi Şu benim departman işinde yeni bir problem çıktı Çok uzun karakterli departman ismim var o olduğu için hata veriyor.Ama onu silip çalıştırınca süperrr..

Maşallah bende öyle bir departman ismi varki 50 küsür kararter

Genel Müdürlük Satış ve Satınalma Müdürlüğü Temizlik İşleri Departmanı - İstanbul

2.Si Sayfalar arası dolaşmak çok zor oluyor.. Acaba indeş buna eklenebilirmi.. Daha önce sayın : V.Basic For Applications yaptığı gibi

 

[okan26]

Teşekkürler...

Heyecandan kaçırmışım yazdığınız ve gönderdiğiniz dosyada istediklerim varmış ?

Saygılar..