BİR DOSYAYI İSTENİLEN ŞEKLE SOKMAK

melwitch · 24 Mayıs 2005

BÃR DOSYAYI ÃSTENÃLEN ÃEKLE SOKMAK

Ekte göndermekte olduğum çalışma sayfasında iki adet sheet bulunmaktadır. Biri "ORJİNAL" adını verdiğim benim asıl dosyam. İkincisi ise bu orjinal sheetindeki tabloyu nasıl bir düzene sokmam gerektiğini gösterir "OLMASI GEREKEN" adlı sheet. Açıklamaları dosyada ayrıntısı ile vermeye çalıştım.

Sanırım bu makroda bana yardımcı olursanız bunun gibi bir çok tabloya göre bunu uyarlayıp kullanabileceğim. Çünkü benim işim tablolarla.

Acil olarak yardım edebilirseniz sevinirim

:hey:

keniken · 24 Mayıs 2005

diğer sıralama da oldu sanırım..

Sizin dosyanızda 1. satırın boş olmadığını kabul edersek şu kodu bi çalıştırın isterseniz..

Sub Grupla()
Sheets("ORJİNAL HALİ").Select
Range("A2").Select
ActiveCell.CurrentRegion.Select
Selection.Sort key1:="BÃ?LÜM", order1:=xlAscending, _
key2:="YERİ", order2:=xlAscending, header:=True
Selection.Subtotal GroupBy:=7, Function:=xlSum, TotalList:=Array(20, 25), _
Replace:=False, PageBreaks:=False, SummaryBelowData:=True
Range("c2").Select
Selection.CurrentRegion.Select
rc = Selection.Rows.Count
Range("g2").Select
u = 1
Do Until u > rc + 1
u = u + 1
Cells(u, 7).Select
If Right(ActiveCell.Value, 5) = "Total" Then
Selection.EntireRow.Select
Selection.Font.Italic = True
Selection.Font.Bold = True
Range("C" & u & ":AE" & u).Select
Selection.Font.Bold = True
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With
Cells(u, 3).Select
End If
Loop

End Sub

melwitch · 24 Mayıs 2005

maalesef hata veriyor.

Selection.Sort key1:="BÃ?LÜM", order1:=xlAscending, _
key2:="YERİ", order2:=xlAscending, header:=True

bu kısım sarı yanıyor. Ayrıca birinci satır boş değil derken, orada tablonun başlığı yer alıyor aslında. O nedenle tablo 2.satırdan başlıyor.

Ancak ben birinci satıra kaydırarakta denedim makroyu, yine aynı hatayı verdi.

Normalde 2.satırdan başlayacak tablom.

Bu arada ilgilendiğiniz için çok teşekkür

red_lion_72 · 24 Mayıs 2005

Sayfanızda veri olan kısmı seçip ad kutusunda "BÃ?LÜM" diye adlandırmanız lazım ama ondan sonra da hata veriyor....

ownn · 24 Mayıs 2005

selam;
bu işi makrosuz da özet tablo kullanarak çözebilirsizni..

ekte örnek bir dosya mevcut.

keniken · 25 Mayıs 2005

Sizde çalışmaması ilginç..Ben herkes kodları görebilsin diye dosyayı göndermek istememiştim..İsterseniz ekteki dosyayı inceleyin..

melwitch · 25 Mayıs 2005

muhteşemsin keniken... :dua: :bravo:

bizimkinde neden çalışmadığını anladım. Tablodaki başlıklardan bazılarının boş olması sanırım problem yarattı. Aklıma da gelmemişti doldurmam gerektiği.

Dosyayı gönderirken bir şey eklemeyi unutmuşum. O konuda da yardımcı olursan sevinirim.

Aynı workbook içerisinde bir çok buna benzer sheet var ve ben bu makroyu hangi sheet aktif ise onda kullanmak istesem kodu nasıl değiştirebilirim. :?

syg

keniken · 25 Mayıs 2005

1. Herhangi bir sayfada kullanmak için "Sheets("ORJİNAL HALİ").Select " satırı yerine "Activesheet.Select " yazın..O sayfada makroyu çalıştırın

2. Tablo başlığınız birinci satırdaydı, ne yaptınız merak ettim? Tavsiyem sayfanın "header" kısmına başlıkları eklemeniz (formülle yazılmadıysa tabii!)

3.

muhteşemsin keniken...

ne haddime, bunca usta varken!!

melwitch · 25 Mayıs 2005

keniken şimdi kendi dosyama aktardım makroyu ancak bazı problemlerle karşılaştım. Belik bir öncekinde doğru aktaramamışta olabilirim. Bu hataların net görülebilmesi için dosyadaki bilgileri arttırıp bazı şeyleri değiştirdim. (Rahat görülsün diye)

Çalışma dosyası senin makronu içeren datası biraz değişmiş tablo.
Çalışma 1 tablosu ise makroyu çalıştırdığımda olan tablo ve gerekli açıklamaları yazdığım tablo. Bir bakarsan sevinirim

keniken · 25 Mayıs 2005

sırayla gidelim istersen..

Ekteki kodları bi dene..Ne istediğini sonra yaz..

Sub Grupla()
ActiveSheet.Select
Range("A2").Select
ActiveCell.CurrentRegion.Select
rc = Selection.Rows.Count
Selection.Sort key1:="YERİ", order1:=xlAscending, header:=True
Dim myrange As Range
q = 2
p = 0
Do While q < rc
Cells(q, 3).Select
If IsEmpty(ActiveCell) Then
q = q + 1
Cells(q, 3).Select
End If
ActiveCell.CurrentRegion.Select
Set myrange = Selection.Offset(0, 2).Resize(ActiveCell.CurrentRegion.Rows.Count, ActiveCell.CurrentRegion.Columns.Count - 1)
myrange.Select
Cells(q, 32) = Application.WorksheetFunction.VLookup(Cells(q, 3), myrange, 30, False)
If Cells(q, 32) = "" Then
p = p + 1
Cells(q, 32) = p
End If
q = q + 1
Loop
Range("A2").Select
ActiveCell.CurrentRegion.Select
Selection.Sort key1:=Range("AF1"), order1:=xlAscending, key2:="YERİ", order2:=xlAscending, _
header:=True
Selection.Subtotal GroupBy:=7, Function:=xlSum, TotalList:=Array(20, 25), _
Replace:=False, PageBreaks:=False, SummaryBelowData:=True

Range("AF:AF").Delete
Range("c2").Select
Selection.CurrentRegion.Select
Range("g2").Select
u = 1
Do Until u > rc + 1
u = u + 1
Cells(u, 7).Select
If Right(ActiveCell.Value, 5) = "Total" Then
Selection.EntireRow.Select
Selection.Font.Italic = True
Selection.Font.Bold = True
Range("C" & u & ":AE" & u).Select
Selection.Font.Bold = True
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With
Cells(u, 3).Select
End If
Loop

End Sub

melwitch · 25 Mayıs 2005

"N" kolonuna göre sıraya girdi. ("M" ve "Y" yazan hücreler alfabetik sırada). Ancak ikinci aşamada "M" yazan hücrelerde kendi içinde "T" kolonunda yer alan total lere göre sıraya girmeli.

* Sonrasında, "T" ye göre sıraya girmiş "G" kolonu aynı olan hücrelerde kendi içinde "C" ye ve sonra "F" ye göre sıraya girsin.

İşin diğer türlü açıklaması tabloda yapılmak istenen,

Aynı "yer"de olanların satış rakamlarına göre sıraya girmesi gerekmekte. Büyükten küçüğe. Sonrasında aynı "yer" deki aynı "bölüm" de olanların kendi içinde düzenlenmesi gerekmekte. Buda şehir ve kişi sıralamasıyla olmalıdır. yine büyükten küçüğe.

Umarım anlatabilmişimdir.

keniken · 25 Mayıs 2005

Bi de şunu deneyelim..

Sub Grupla()
ActiveSheet.Select
Range("A2").Select
ActiveCell.CurrentRegion.Select
rc = Selection.Rows.Count
Selection.Sort Key1:="YERİ", Order1:=xlAscending, Header:=True
Dim myrange As Range
q = 2
p = 0
Do While q < rc
Cells(q, 3).Select
If IsEmpty(ActiveCell) Then
q = q + 1
Cells(q, 3).Select
End If
ActiveCell.CurrentRegion.Select
Set myrange = Selection.Offset(0, 2).Resize(ActiveCell.CurrentRegion.Rows.Count, ActiveCell.CurrentRegion.Columns.Count - 1)
myrange.Select
Cells(q, 32) = Application.WorksheetFunction.VLookup(Cells(q, 3), myrange, 30, False)
If Cells(q, 32) = "" Then
p = p + 1
Cells(q, 32) = p
End If
q = q + 1
Loop
Range("A2").Select
ActiveCell.CurrentRegion.Select
Selection.Sort Key1:=Range("AF1"), Order1:=xlAscending, Key2:="SATIÃ", Order2:=xlDescending, _
key3:="KİÃİ", order3:=xlAscending, Header:=True
Selection.Subtotal GroupBy:=7, Function:=xlSum, TotalList:=Array(20, 25), _
Replace:=False, PageBreaks:=False, SummaryBelowData:=True
Range("AF:AF").Delete
Range("c2").Select
Selection.CurrentRegion.Select
rc = Selection.Rows.Count
Range("g2").Select
u = 1
Do Until u > rc + 1
u = u + 1
Cells(u, 7).Select
If Right(ActiveCell.Value, 5) = "Total" Then
Cells(u, 14) = Cells(u - 1, 14)
Selection.EntireRow.Select
Selection.Font.Italic = True
Selection.Font.Bold = True
Range("C" & u & ":AE" & u).Select
Selection.Font.Bold = True
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With
Cells(u, 3).Select
End If
Loop
ActiveSheet.Outline.ShowLevels rowlevels:=2
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Sort Key1:="YERİ", Order1:=xlAscending, Key2:="SATIÃ", Order2:=xlDescending, _
Header:=True
ActiveSheet.Outline.ShowLevels rowlevels:=3
End Sub

melwitch · 25 Mayıs 2005

"M" ve "Y" yazan hücrelerin sıralaması tamam ve "M" yazan hücrelerin toplam satışlara görede sıralaması doğru görünüyor ancak "Y" yazan hücrelerde toplam satışlara göre sıralama doğru çıkmamakta.

melwitch · 25 Mayıs 2005

Keniken gönderdiğim dosyada sheet 1 diye bir yer açtım ve oraya manuel olarak olması gerken halini yaptım. Orjinal Hali kısmında senin son makron kayıtlı. Yanlız orada bir şeyi değiştirmek zorunda kaldım oda şehir isimlerinden bazılarını. Çünkü farkında olmadan hepsini aynı yapmışım (aynı bölüme ait olanlarınkileri) ve bu nedenle makronun doğru işleyip işlemediği görülemiyordu. Tabi benim ana dosyamda ÃEHİR kısmıda sıralama gireceğinden sorun ancak orada görülebiliyordu.

NEyse eğer dosyaya bir göz atarsan ve makro çalıştırdığından "ORJİNAL HALİ" isimli sheet "sheet1" le eşleşiyorsa sorun yok demek olacak. Tabi bu seni uğraştıracak gibi görünüyor ama yardım edebilirsen çok makbule geçecek.

ama neden dosyayı ekleyemiyorum onu anlamadım.

ALPEN · 25 Mayıs 2005

http://www.excel.web.tr/viewtopic.php?t=5323

keniken · 25 Mayıs 2005

bu akşama kadar dosya ekleyip gönderme deactive olmuş..İstersen maille gönder..

melwitch · 26 Mayıs 2005

Makronun son hali aşağıda yer almaktadır. Belki başka arkadaşların işine de yarayabilir düşüncesiyle gönderiyorum.

Bu makroda bana yardımcı olan keniken e çok ama çok teşekkürler. :bravo: :bravo: :bravo: :bravo:

Sub Grupla()
ActiveSheet.Select
Range("A2").Select
ActiveCell.CurrentRegion.Select
rc = Selection.Rows.Count
Selection.Sort Key1:="YERİ", Order1:=xlAscending, Header:=True
Dim myrange As Range
q = 2
p = 0
Do While q < rc
Cells(q, 7).Select
If IsEmpty(ActiveCell) Then
q = q + 1
Cells(q, 7).Select
End If
ActiveCell.CurrentRegion.Select
Set myrange = Selection.Offset(0, 6).Resize(ActiveCell.CurrentRegion.Rows.Count, ActiveCell.CurrentRegion.Columns.Count - 1)
myrange.Select
Cells(q, 32) = Application.WorksheetFunction.VLookup(Cells(q, 7), myrange, 26, False)
If Cells(q, 32) = "" Then
p = p + 1
Cells(q, 32) = p
End If
q = q + 1
Loop
Range("A2").Select
ActiveCell.CurrentRegion.Select
Selection.Sort Key1:=Range("AF1"), Order1:=xlAscending, Key2:="KİÃİ", Order2:=xlAscending, _
Key3:="SATIÃ", Order3:=xlDescending, Header:=True
Selection.Subtotal GroupBy:=7, Function:=xlSum, TotalList:=Array(20, 25), _
Replace:=False, PageBreaks:=False, SummaryBelowData:=True
t = Cells(rc, 32)
Range("AF:AF").Delete
Range("c2").Select
Selection.CurrentRegion.Select
rc = Selection.Rows.Count
Range("g2").Select
u = 1
Do Until u > rc + 1
u = u + 1
Cells(u, 7).Select
If Right(ActiveCell.Value, 5) = "Total" Then
Cells(u, 14) = Cells(u - 1, 14)
Selection.EntireRow.Select
Selection.Font.Italic = True
Selection.Font.Bold = True
Range("C" & u & ":AE" & u).Select
Selection.Font.Bold = True
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With
Cells(u, 3).Select
End If
Loop
ActiveSheet.Outline.ShowLevels rowlevels:=2
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Sort Key1:="YERİ", Order1:=xlAscending, Key2:="SATIÃ", Order2:=xlDescending, _
Header:=True
ActiveSheet.Outline.ShowLevels rowlevels:=3
Range("a2").Select
u = 0
Do Until u > rc + t
u = u + 1
Cells(u, 7).Select
If Right(ActiveCell.Value, 5) = "Total" Or Right(ActiveCell.Value, 5) = "BÃ?LÜM" Then
Cells(u + 1, 7).Select
Selection.EntireRow.Insert
End If
Loop
u = 1
Do Until u > rc + 2 * t
u = u + 1
Cells(u, 7).Select
If ActiveCell.Value = "Grand Total" Then Exit Do
If IsEmpty(Cells(u + 1, 7)) Then
Selection.CurrentRegion.Select
Selection.Sort Key1:=Range("C:C"), Order1:=xlAscending, Key2:=Range("F:F"), Order2:=xlAscending, _
Key3:=Range("T:T"), Order3:=xlAscending, Header:=False
End If
Loop
u = 0
Do Until u > rc + 2 * t
u = u + 1
Cells(u, 7).Select
If IsEmpty(ActiveCell) Then
Selection.EntireRow.Delete
End If
Loop

End Sub