• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Bir sütun için çalışan makroyu diğer sütunlara otomatik taşıma

A

acidmaster

Katılım
28 Ocak 2011
Mesajlar
10
Excel Vers. ve Dili
2010 vb
Merhabalar bir makrom var sayfamda oluşturduğum verileri b sütunundan başlamak üzere küçükten büyüğe sıralıyor(sıralama geniş seçim olarak yapılıyor) sıralama bitince bana bir user formda evet hayır seçenekleri sunuyor.Evet der isem sıralama yapılan sütunun ilk hücresini bir renkli işaretliyor hayır dersem userform kapanıyor.Benim sorunum şu bu şekilde yapılması gereken 100 civarı sütunum var.B sütunu bitince c sütununa göre sıralayacak ve gene form çıkacak evet dersem c1 i renkli işaretleyecek.Bu sona kadar gidecek bu sistemi nasıl yapabilirim acaba.Tek sütun için olan kısmı yazdım.For döngüsü kullanark yapmayı denedim ancak command buton a verdiğim değerde işaretlemesi gereken hücreyi ilerletemedim.Yardımcı olurmusunuz?
 
Dosya ekleyemedim.Çalışma kitabı uzantısı .xlsm bunu kabul etmiyor.

Module içeriği:

Sub Makro3()
'
' Makro3 Makro
'
' Klavye Kısayolu: Ctrl+j
'
Dim i As Integer

For i = 1 To 11



Columns(i).Select
ActiveWorkbook.Worksheets("Sayfa1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sayfa1").Sort.SortFields.Add Key:=Range("B2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sayfa1").Sort
.SetRange Range("yeah")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With


Load UserForm1
UserForm1.Show

Next i

End Sub


Command buton evet içeriği


Private Sub CommandButton1_Click()
Dim i As Integer
i = 2
i = i + 1
Columns(i).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With


Unload UserForm1
End Sub

Command buton hayır içeriği

Private Sub CommandButton2_Click()
Unload UserForm1
End Sub
 
Bazı kısımları bir şekilde çözdüm ancak range içinde değişkeni nasıl tanımlayabilirim sorun veriyor

range( i & "2") bu şekilde kabul etmiyor

Key:=Range("B2") çalışan şekli bu ancak ben bunu tanımladığım i değişkeni ile değişmesini istiyorum .Yardımcı olabilecek varmı ?
 
acidmaster' Alıntı:
Bazı kısımları bir şekilde çözdüm ancak range içinde değişkeni nasıl tanımlayabilirim sorun veriyor

range( i & "2") bu şekilde kabul etmiyor

Key:=Range("B2") çalışan şekli bu ancak ben bunu tanımladığım i değişkeni ile değişmesini istiyorum .Yardımcı olabilecek varmı ?
Genişletmek için tıkla ...
Range yerine bunu kullanın:
Kod: 
Cells(2,i)
"2" satır numarası "i" sütun numarasını karşılıyor.
 
üstad aşağıdaki kodda key:=range("B2") kısmına senin dediğin cells(2,i) kodunu yazarsam hata veriyor veri sıralamasını yapmıyor.Sıralama başvurusu geçerli değil diye uyarı veriyor.Yardımcı olurmusun.


Columns(i).Select
ActiveWorkbook.Worksheets("Sayfa1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sayfa1").Sort.SortFields.Add Key:=Range("b2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sayfa1").Sort
.SetRange Range("a1:k38")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
 
Merhaba,
1. mesajınızdan hareketle kodlarınızı kendi metodlarıma göre düzenledim. Verdiğiniz bilgilere göre userforma gerek olmadığını düşünerek, userform yerine daha pratik olması açısından msgbox kullandım. Kodu çalıştırdığınızda Msgbox açılacak sütun numarasını belirterek size belirttiğiniz soruyu yönlendirecek. Evet derseniz istediğiniz gibi o sütunun ilk hücresi kırmızı renge boyanacak. İsteğiniz dışında içereisinde veri olmayan sütundan işlem yapmadan diğer satırdan devam etmesini sağlayacak bir satır ekledim.
Kod: 
Sub Sirala()
Dim i As Integer
For i = 2 To 11
Sat = Range("a2:l65536").SpecialCells(xlCellTypeLastCell).Row
Set Aralik = Range("a2:l" & Sat)
If WorksheetFunction.CountA(Range(Cells(2, i), Cells(Sat, i))) = 0 Then GoTo Atla
Aralik.Sort Key1:=Cells(2, i), Order1:=xlAscending, Header:=xlNo, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
        Sor = MsgBox("Bu sütun işaretlensin mi? Sütun no: " & i, vbYesNo)
        If Sor = vbYes Then
            Cells(1, i).Interior.ColorIndex = 3
        End If
Atla:
Next i
End Sub
 

Ekli dosyalar

Üstad eline sağlık çok güzel olmuş.Ayrıca kodlarından baya bi ders aldım kendime.Ancak şimdi fark ettiğim bir sorun var.yaptığın sıralamada sütun sadece kendi içinde sıralama yapıyor.Benim istediğim örneğin D sütununa göre sıralama yağtığımda A sütunundakilerin değişimi.Bu normalde sıralamada seçimi genişlet şeklinde seçince yapıyor bunu.O konuda yardımcı olabilirmisin.
 
Son düzenleme:
Merhaba,
Kodu ve dosyayı güncelledim. Yeniden deneyebilirsiniz.
 
Üstad eline sağlık tam istediğim gibi olmuş.Ancak gene bir sorun çıktı For i = 2 To 88 yaptıgımda 12 döngüde hata veriyor ?
 
Son düzenleme:
acidmaster' Alıntı:
Üstad eline sağlık tam istediğim gibi olmuş.Ancak gene bir sorun çıktı For i = 2 To 88 yaptıgımda 12 döngüde hata veriyor ?
Genişletmek için tıkla ...
Merhaba,
Kodu eklediğiniz dosyaya göre yazdım. Sizin uyarladığınız dosyada ne var ne yok bilemediğimden hatanın sebebini bilemiyorum. Ancak tahmini olarak şunu söyleyebilirim. Belirttiğim aralık "L" sütununda bitiyor. Döngüyü artırdığınız oranda aralığı da artırmanız gerekli.
 
Evet belirttiğiniz kısım L sütununda bitiyor oda 12. döngü bu aralığı yükselteceğim kısım hangisi acaba çözemedim o kısmı benim uyguladımğım kısımda 88 döngü var ve "DJ" sütununda bitiyor.
 
Merhaba,
88 döngüye uyarlanmış şekli aşağıdadır:
Kod: 
Sub Sirala()
Dim i As Integer
For i = 2 To 88
Sat = Range(Cells(2, 1), Cells(65536, 89)).SpecialCells(xlCellTypeLastCell).Row
Set Aralik = Range(Cells(2, 1), Cells(Sat, 89))
If WorksheetFunction.CountA(Range(Cells(2, i), Cells(Sat, i))) = 0 Then GoTo Atla
Aralik.Sort Key1:=Cells(2, i), Order1:=xlAscending, Header:=xlNo, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
        Sor = MsgBox("Bu sütun işaretlensin mi? Sütun no: " & i, vbYesNo)
        If Sor = vbYes Then
            Cells(1, i).Interior.ColorIndex = 3
        End If
Atla:
Next i
End Sub
 
üstad eline sağlık byük bir dertten kurtardın beni
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst