Sutunda verileri aşağı doğru kaydırma

[YTalisman]

Merhaba,

Ekteki dosyada A kolonunda bulunan X değerlerinden sildiğimde B kolonundaki değerleri C kolonunda bir aşağı kaydırarak yazması. Ekteki dosyada istediğim similasyonu C kolonuna işledim.

Yardımlarınız için şimdiden teşekkürler,

 

[Muzaffer Ali]

Merhaba.
VBA kod ile çözümü ektedir.

 

[YTalisman]

Merhaba,
Cevabınız için teşekkür ederim fakat. X silip tekrar yazıp sildikçe aşağı doğru kaydırmaya devam ediyor. X sildikçe kaydıracak tekrar yazdığımızda geri alacak gibi yapabilirmiyiz.

 

[Muzaffer Ali]

Bunun formül ile yapılabileceğini sanmıyorum. Belki yapılabilir ama çok uzun formül gerektirir ve dosyanızı ağırlaştırır. Kullanışlı olmaz.

 

[Muzaffer Ali]

2. mesajdaki dosyayı yeniledim.

 

[YTalisman]

Merhaba,

2 Tane X alt alta sildiğimde hata yapıyor.

X 1%​ 1%​ X 3%​ 3%​ X 5%​ 5%​ x 10%​ 10%​ X 20%​ 20%​ X 25%​ 25%​ 30%​ 30%​ X 35%​ 30%​ X 39%​ 35%​ 40%​ 39%​ X 41%​ 40%​ X 45%​ 40%​ 46%​ 41%​ 47%​ 45%​ X 48%​ 46%​ X 49%​ 46%​ X 51%​ 47%​ X 53%​ 47%​ X 55%​ 48%​

 

[Muzaffer Ali]

Yanına doğru sonucu yazarak gösterir misiniz.

 

[YTalisman]

Merhaba,

Sistemin bu şekilde çalışması lazım.

X	1%​	1%​
X	3%​	3%​
X	5%​	5%​
x	10%​	10%​
X	20%​	20%​
X	25%​	25%​
	30%​	30%​
X	35%​	30%​
X	39%​	35%​
	40%​	39%​
X	41%​	39%​
X	45%​	40%​
	46%​	41%​
	47%​	41%​
X	48%​	41%​
X	49%​	45%​
X	51%​	46%​
X	53%​	47%​
X	55%​	48%​

 

[Muzaffer Ali]

1- 39% nin yanında X yazıyor ama C de iki tane 39% olması lazım diyorsunuz? (Bir tane olması lazım)
2- 40% nin yanında X yazmıyor ama C de bir tane 40% var. (İki tane olması lazım)
3- 46% nin yanında X yazmıyor ama C de bir tane 46% var. (İki tane olması lazım)
4- 47% nin yanında X yazmıyor ama C de bir tane 47% var. (İki tane olması lazım)

Burayı anlamadım neden böyle olması gerekiyor? Eğer bu böyle olacaksa 1. mesajda söylediklerinize ters düşüyor.
Sanırım ben soruyu anlamadım.

 

[YTalisman]

Merhaba,
%39 un yanında X yazıyor. %30 un karşısındaki X olmadığı için bir alta kayarak geliyor. %35 yazması doğru. %40 ın yazındaki X de olmadığı için %41 in karşısına %39 yazması doğru.

Yani kısacası B kolonu bir yerden sonra devreden çıkıyor. C kolonunu aslında aşağıya doğru kaydırması gerekiyor. B kolonun sadece hangi sayıdan sonra ne gelmesi gerektiğini gösteren bir tablo gibi düşünün.

 

[Muzaffer Ali]

O zaman B sütununu hiç dikkate almayacağım doğru mu?

Sayfanın kod kısmındaki kodu silip yerine aşağıdakini kopyalayın.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count = 1 Then
        If Not Intersect(Range("A:A"), Target) Is Nothing Then
            Application.EnableEvents = False
            If Target = "" Then
                Target(1, 3).Copy
                Target(1, 3).Insert Shift:=xlDown
                Application.CutCopyMode = False
            Else
                Target(1, 3).Delete Shift:=xlUp
            End If
            Application.EnableEvents = True
        End If
    End If
End Sub

 

[YTalisman]

Merhaba,

Bu kod istediğim gibi çalışmıyor. Tekrardan istediğimi anlatmak istiyorum.

A kolonundaki X i sildiğimizde B kolonundaki değeri C kolonundaki bir alt hücreye yazması. Daha sonra aşağıdaki satırlarda A kolonundaki X i sildiğimizde en son A kolonundaki X yazan hücrenin karşısında bulunan C kolonundaki değerden sonraki B Kolonunda yazan değerin bir altında bulunan değeri C Kolonuna yazması. Anlatması ve anlaması biraz zor oldu ama.

Yani bu şekilde çalışacak.

X	1%	1%
X	3%	3%
X	5%	5%
x	10%	10%
X	20%	20%
X	25%	25%
	30%	30%
X	35%	30%
X	39%	35%
	40%	39%
X	41%	39%
X	45%	40%
	46%	41%
	47%	41%
X	48%	41%
X	49%	45%
X	51%	46%
X	53%	47%
X	55%	48%

İyi Günler,

 

[Muzaffer Ali]

1 inci X2i silmeden önce B ve C sütunları her zaman eşit değil mi?
Eğer eşitse
1 inci X'i sildiğinizde b'yi dikkate alsa yada c'yi dikkate alsa bir şey değişemez ki. Zaten hepsi aynı sırada değil mi?

11. mesajda yazdığım kodu denediniz mi?

 

[Muzaffer Ali]

Olmadıysa bir de bunu deneyin.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Stn As Long
    If Target.Count = 1 Then
        If Not Intersect(Range("A:A"), Target) Is Nothing Then
            Application.EnableEvents = False
            If Target = "" Then
                If WorksheetFunction.CountIf(Range("A:A"), "<>") + 1 = Cells(Rows.Count, "A").End(xlUp).Row Then
                    Stn = 2
                Else
                    Stn = 3
                End If
                Target(1, Stn).Copy
                Target(1, 3).Insert Shift:=xlDown
                Application.CutCopyMode = False
            Else
                Target(1, 3).Delete Shift:=xlUp
            End If
            Application.EnableEvents = True
        End If
    End If
End Sub

 

[YTalisman]

Merhaba,

Sonuca çok yaklaştık yanlız şu şekilde olabilir mi? Yeni açtığım D kolonundaki gibi C kolonunu dizmeli. Teşekkürler,

X	1%​	1%​
X	3%​	3%​
	5%​	5%​
X	10%​	5%​
X	20%​	10%​
X	25%​	20%​
X	30%​	25%​
X	35%​	30%​
	39%​	35%​		Boş Olan X satırındaki C kolonundaki değer İlk Doldurulacak X satırındaki C kolonuna yazmalı.
	40%​	39%​
X	41%​	39%​	35%​
X	45%​	40%​	39%​
X	46%​	40%​	40%​
X	47%​	41%​	41%​
X	48%​	45%​	45%​
X	49%​	46%​	46%​
X	51%​	47%​	47%​
X	53%​	48%​	48%​
X	55%​	49%​	49%​
X	57%​	51%​	51%​
X	58%​	53%​	53%​
X	59%​	55%​	55%​
X	60%​	57%​	57%​
X	61%​	58%​	58%​
X	62%​	59%​	59%​

 

[YTalisman]

Merhaba Muzaffer Ali bey,

Aşağıdaki kodu C3 D3 E3 hücrelerinde çalışabilecek gibi güncelleyebilir misiniz.


Private Sub Worksheet_Change(ByVal Target As Range)
Dim Stn As Long
If Target.Count = 1 Then
If Not Intersect(Range("A:A"), Target) Is Nothing Then
Application.EnableEvents = False
If Target = "" Then
If WorksheetFunction.CountIf(Range("A:A"), "<>") + 1 = Cells(Rows.Count, "A").End(xlUp).Row Then
Stn = 2
Else
Stn = 3
End If
Target(1, Stn).Copy
Target(1, 3).Insert Shift:=xlDown
Application.CutCopyMode = False
Else
Target(1, 3).Delete Shift:=xlUp
End If
Application.EnableEvents = True
End If
End If
End Sub

 

[Muzaffer Ali]

"A:A" yazan yerleri "C:C"
"A" yazan yerleri "C" ile değiştirmeniz yeterli
Ben düzelttim.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Stn As Long
    If Target.Count = 1 Then
        If Not Intersect(Range("C:C"), Target) Is Nothing Then
            Application.EnableEvents = False
            If Target = "" Then
                If WorksheetFunction.CountIf(Range("C:C"), "<>") + 1 = Cells(Rows.Count, "C").End(xlUp).Row Then
                    Stn = 2
                Else
                    Stn = 3
                End If
                Target(1, Stn).Copy
                Target(1, 3).Insert Shift:=xlDown
                Application.CutCopyMode = False
            Else
                Target(1, 3).Delete Shift:=xlUp
            End If
            Application.EnableEvents = True
        End If
    End If
End Sub

 

[YTalisman]

Merhaba,

Aynı C kolonunda aynı hücreye durmadan X yazarsam yada aynı hücrede sürekli delete tuşuna basarsam macro durmadan çalışıyor.

Aynı hücreye sürekli X yazsam da macro bir kez çalışsın. Aynı şekil dlete yapsamda bir kez çalışsın.

İyi Günler,

 

[Muzaffer Ali]

Bu kodu kullanın.

Dim X As Variant

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Stn As Long
    If Target.Count = 1 And UCase(Target.Value) <> UCase(X) Then
        If Not Intersect(Range("C:C"), Target) Is Nothing Then
            Application.EnableEvents = False
            If Target = "" Then
                If WorksheetFunction.CountIf(Range("C:C"), "<>") + 1 = Cells(Rows.Count, "C").End(xlUp).Row Then
                    Stn = 2
                Else
                    Stn = 3
                End If
                Target(1, Stn).Copy
                Target(1, 3).Insert Shift:=xlDown
                Application.CutCopyMode = False
            Else
                Target(1, 3).Delete Shift:=xlUp
            End If
            X = Target.Value
            Application.EnableEvents = True
        End If
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    X = Target.Value
End Sub