• DİKKAT

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

Satır ekleme ve sıralalama

R

rtk19641990

Katılım
20 Mart 2009
Mesajlar
333
Excel Vers. ve Dili
office 2003 ingilizce
Günaydın,
Ekte yapmak istediğimi açıkladım.
Yardımlarınızı rica ederim.
 

Ekli dosyalar

10 satırdan sonra sarı renkle gösterdiğin 2 adet satır eklemek, 1 numaralı satırdaki başlığı 12.ci satıra
almak, 1-10 arasını H kolonuna göre sort, 12-23 arasını yine H kolonuna göre sort etmek istiyorum.
Genişletmek için tıkla ...

Yukarıda yazılanlar bir kereye mahsus yapılacak ve kriterler değişmeyecekse, bu işlemleri yaparken makro kaydet kullanın modülde oluşan kodlar bu işlemi yapacaktır. Peşpeşe çalıştırırsanız ilave edilen satırlardan dolayı tablo bozulacaktır.

Benim kaydedip biraz sadeleştirdiğim kodlar aşağıda

Kod: 
Sub GereksizBirKod()
    Rows("11:12").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Rows("1:1").Copy
    Rows("12:12").Select
    ActiveSheet.Paste
    Range("A2:H10").Select
    Application.CutCopyMode = False
    Range("A1:H10").Select
    Selection.Sort Key1:=Range("H2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("A12:H23").Select
    Selection.Sort Key1:=Range("H12"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("A11").Select
End Sub
 
şunu dener misniz?
Sub ben()
For x = 10 To [a10000].End(3).Row Step 10
Rows(x + 1).Insert (2)
Rows(x + 1).Insert (1)
Range("a1:h1").Copy
Range("a" & x + 2).PasteSpecial
Rows(x + 1).Interior.Color = vbYellow
Rows(x + 2).Interior.Color = vbYellow
If x < 11 Then
Range("a" & x - 8 & ":" & "h" & x).Sort key1:=Range("h" & x - 8)
Else
Range("a" & x - 7 & ":" & "h" & x).Sort key1:=Range("h" & x - 7)
End If
Application.CutCopyMode = False
Next x
End Sub
 
Benim yapmak istediğim TRHBTR2A ve PAMUTRIS lerin bitiminde 2 satır eklemek ve 1.ci satırdaki başlığı o ayırdığım satıra kopyalamak. Bu kadar. Ancak verdiğiniz kod da her seferinde satır değişecek değil mi? Yani örneğimde 11 den sonra başlıyor. Başka bir satırdan sonra istesem başka satır numarası girmem gerekecek. Parametrik olamaz mı acaba? PAMUTRIS ve TRHBTR2A ların bittiği yeri saptayıp ondan sonra 2 satır eklese.
 
rtk19641990' Alıntı:
Hocam neden gereksiz bir kod dediniz?
Genişletmek için tıkla ...

Gereksiz dedim, çünkü devamlılığı olan bir kod değil bir kere kullanılacak, dolayısyla bu kodu oluşturup bir kere kullanana kadar bu işlemi mouse ile klavye bile kullanmadan yapabilirsiniz. Ancak önünüze sürekli bu tablodan geliyor ve bu formatı vermek istiyorsanız bu kod PERSONEL olarak kaydedilip bir nebze işe yarayabilir. Umarım sizinde işinize yarar.

Kolay Gelsin
 
rtk19641990' Alıntı:
Benim yapmak istediğim TRHBTR2A ve PAMUTRIS lerin bitiminde 2 satır eklemek ve 1.ci satırdaki başlığı o ayırdığım satıra kopyalamak. Bu kadar. Ancak verdiğiniz kod da her seferinde satır değişecek değil mi? Yani örneğimde 11 den sonra başlıyor. Başka bir satırdan sonra istesem başka satır numarası girmem gerekecek. Parametrik olamaz mı acaba? PAMUTRIS ve TRHBTR2A ların bittiği yeri saptayıp ondan sonra 2 satır eklese.
Genişletmek için tıkla ...

PAMUTRIS ve TRHBTR2A lar hep altalta mı dizilmiş ve üsttemi oluyor yani son bulunan PAMUTRIS'den sonra satır eklersek yukarıda olmasını istemediğimiz satırlar olacak mı ? Yoksa öncelikle bunların mı sıralanması gerekir ?
 
pardon gönderdiğin dosyada c sütununda ilk 9 satır TRHBTR2A şeklinde..bunların her birinin sonuna boşluk eklenicek mi ?
 
Evet alt alta ve hep üstte oluyorlar. Sadece bazan örneğin 20 tane TRHBTR2A sonra PAMUTRIS sonra tekrar TRHBTR2A şeklinde ama önemli değil. Bunlar hep üstte yer alıyor. İster TRHBTR2A ister PAMUTRIS olsun en son satırı bulabilirsek yeterli olur. Zaten sıralama makrosunu halletmişsiniz.
 
En son satır bulunup 2 adet satır eklenecek sonra ayrılan kısımdan itibaren yukarısı ve aşağısı H kolonuna göre sort olacak.
 
şunu dener misiniz??

Sub ben()
Set b = Range("c:C").Find("PAMUTRIS")
c = Not b Is Nothing
If c = True Then
sen = b.Address
End If
f = Mid(sen, 4, 1)
f = Mid(sen, 4, 2)
gel:
On Error Resume Next
d = d + 1
Rows(f + 1).Insert
Rows(f + 2).Insert
Range("a1:h1").Copy
Range("a" & f + 2).PasteSpecial
Rows(f + 1).Interior.Color = vbYellow
Rows(f + 2).Interior.Color = vbYellow
If d = 1 Then
Range("a" & 2 & ":" & "h" & f).Sort key1:=Range("h" & 2)
Else
Range("a" & 3 + p & ":" & "h" & f).Sort key1:=Range("h" & p + 3)
End If
Set b = Range("c:C").FindNext(b)
k = b.Address
p = f
If k <> sen Then
f = Mid(k, 4, 1)
f = Mid(k, 4, 2)
GoTo gel
End If
Range("a" & 3 + p & ":" & "h" & [a10000].End(3).Row).Sort key1:=Range("h" & p + 3)
Application.CutCopyMode = False
End Sub
 
Kod süper çalışıyor ancak en altta PAMUTRIS olmayabilir hocam. TRHBTR2A da gelebilir. TRHBTR2A ya da PAMUTRIS hangisi olursa olsun son satırı bulup ondan sonra 2 satır eklemek gerekiyor. Bir de sıralarken önce B sonra A gelebilir mi?
 
Hocam kodunuz biraz karışık geldi. Nasıl yapıldığını anlamaya çalışıyorum da. Mümkünse açıklama yapabilir misiniz?
Mid ler ne iş yapıyor?
Neresi sort ediyor? gibi
 
şunu deneyiniz...bu arada mid (parçaal) fonksiyonunun vba daki yazılışı..sort eden kısım ise
Range("a" & 2 & ":" & "h" & f).Sort key1:=Range("h" & 2), order1:=xlDescending kısmı..tabi burası biraz karşık..çok fazla değişken kullandım..sanırım daha kolay bir yolu muhakkak vardır ..beni aşıyo sanırım :) kodu module kopyaladıktan sonra f8 ile adım adım hareket ederseniz ve mouse ile sürekli değişkenlerin hangi değerleri aldığına bakarsanız daha rahat anlayabilirsiniz..ayrıca tek bir "PAMUTRIS" için değil bütün "PAMUTRİS" kelimeleri için işlem yapıyo..tek bir tane olsa kısa birşeyle halolurdu sanırım..kolay gelsin..


Sub ben()
Application.ScreenUpdating = False
Set b = Range("c:C").Find("PAMUTRIS")
c = Not b Is Nothing
If c = True Then
sen = b.Address
End If
f = Mid(sen, 4, 1)
f = Mid(sen, 4, 2)
gel:
On Error Resume Next
d = d + 1
Rows(f + 1).Insert
Rows(f + 2).Insert
Range("a1:h1").Copy
Range("a" & f + 2).PasteSpecial
Rows(f + 1).Interior.Color = vbYellow
Rows(f + 2).Interior.Color = vbYellow
If d = 1 Then
Range("a" & 2 & ":" & "h" & f).Sort key1:=Range("h" & 2), order1:=xlDescending
Else
Range("a" & 3 + p & ":" & "h" & f).Sort key1:=Range("h" & p + 3), order1:=xlDescending
End If
Set b = Range("c:C").FindNext(b)
k = b.Address
p = f
If k <> sen Then
f = Mid(k, 4, 1)
f = Mid(k, 4, 2)
GoTo gel
End If
Range("a" & 3 + p & ":" & "h" & [a10000].End(3).Row).Sort key1:=Range("h" & p + 3), order1:=xlDescending
For Z = [a10000].End(3).Row To p + 3 Step -1
If Cells(Z, "c") = "TRHBTR2A" Then
Rows(Z + 1).Insert
Rows(Z + 2).Insert
Range("a1:h1").Copy
Range("a" & Z + 2).PasteSpecial
Rows(Z + 1).Interior.Color = vbYellow
Rows(Z + 2).Interior.Color = vbYellow
GoTo j
End If
Next Z
j:
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
 
Bir önceki kod yapıyordu ama o da PAMUTRIS dikkate alıyor. Ona göre ayırıyor
 
1.ci kodda PAMUTRIS birinci satırda ise 1.ci satırdan sonra 2 satır açıyor. 5.ci satırda ise 5 den sonra açıyor. 2ci kodda PAMUTRIS ten sonra iki TRHBTR2A dan sonra iki satır açıyor.
Benim yapmak istediğim TRHB ve PAMU içeren satırların sonundan sonra 2 adet satır açabilmek. Ama yine de teşekkürler uğraştığınız için.
 
Bu şekilde istediğim yerden ayırdı:sadece sort olayını araya koyamadım.
Sub ayır()
For Z = [a10000].End(3).Row To p + 3 Step -1
If Cells(Z, "C") = "TRHBTR2A" Or Cells(Z, "C") = "PAMUTRIS" Then
Rows(Z + 1).Insert
Rows(Z + 2).Insert
Range("a1:h1").Copy
Range("a" & Z + 2).PasteSpecial
Rows(Z + 1).Interior.Color = vbYellow
Rows(Z + 2).Interior.Color = vbYellow
GoTo j
End If
Next Z
j:
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst