Koşullu satır kopyalama ve satır kaydırma

[ahzola]

Merhabalar ekteki dosyama yardımlarınızı bekliyorum
değerli uzman arkadaşlar.

 

[Huseyinkis]

Merhabalar ekteki dosyama yardımlarınızı bekliyorum
değerli uzman arkadaşlar.

Ekli kodları denermisiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A1:A65536]) Is Nothing Then Exit Sub
If Cells(Target.Row, 1).Value = 1 Then
Rows(Target.Row + 1).Insert
On Error Resume Next
For i = 2 To 6
Cells(Target.Row + 1, i).Value = Cells(Target.Row, i).Value
Next
ElseIf Cells(Target.Row, 1).Value = 2 Then
sonsat = Cells(Rows.Count, 2).End(3).Row + 1
For a = 2 To 6
Cells(sonsat, a).Value = Cells(Target.Row, a).Value
Cells(Target.Row, a).Value = ""
Next
End If
End Sub

 

[ahzola]

Hüseyin Bey;

alakanız için teşekkür ederim öncelikle
ekli dosyada küçük bir hata yapmışım mazur görünüz lütfen.

A sütununa girilen verileri
1 2 değilde
1 0 olarak change edebilirmisiniz acaba.

 

[Murat OSMA]

Kodlara bir bakarsanız siz de yapabilirsiniz...

 

[ahzola]

Mesajımı yazmadan önce denedim
Runtime error 1004 diyor...

 

[Murat OSMA]

Hangi satırda değişiklik yaptınız ?

 

[ahzola]

2 lerin hepsini 0 yaptım.
ben makrodan hiç anlamıyorum.
sanırım sıkıntı burada.

 

[Huseyinkis]

Mesajımı yazmadan önce denedim
Runtime error 1004 diyor...

0 alt satıra ekleme
1 en alta atma

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A1:A65536]) Is Nothing Then Exit Sub
If Cells(Target.Row, 1).Value = 0 Then
Rows(Target.Row + 1).Insert
On Error Resume Next
For i = 2 To 6
Cells(Target.Row + 1, i).Value = Cells(Target.Row, i).Value
Next
ElseIf Cells(Target.Row, 1).Value = 1 Then
sonsat = Cells(Rows.Count, 2).End(3).Row + 1
For a = 2 To 6
Cells(sonsat, a).Value = Cells(Target.Row, a).Value
Cells(Target.Row, a).Value = ""
Next
End If
End Sub

 

[ahzola]

Maalesef formülümüz sağlıklı çalışmadı. Kopyalamayı
Bir nebze olsun yapıyor (bazı işlemleri es geçiyor)
Ama kaydırma/taşıma olayında sorun var.

Ekteki dosya üzerinde uygulama yapılırsa sanırım
daha faydalı olacaktır.

a sütununda 0 ve 1 değerlerini kullanacağız.
kopyanın herşeyiyle birebir aynısı olmak zorunda.
taşımayı ise değer bulunun en son satırın altına taşıyacak.

teşekkürler.

 

[Huseyinkis]

Ben işlemi a sutununa yazınca b den F ye kadar olan satırları kopyalaması için yapmiştım sizin dosyada k ile başlıyor devam ediyor.

For i = 11 to 20 ve for a=11 to 20 kodarda 11 sutun yani "K" sutunundan başla 20 sutuna kadar kopyala anlamındadır eğer sizin dosyanızda gizlediğiniz satırlarda B ile K arasındakilerde veri varsa ve kopyalamasını veya aşağı taşımasını istiyorsanız For =2 to 20 yapın..

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A1:A65536]) Is Nothing Then Exit Sub
If Cells(Target.Row, 1).Value = 0 Then
Rows(Target.Row + 1).Insert
On Error Resume Next
For i = 11 To 20
Cells(Target.Row + 1, i).Value = Cells(Target.Row, i).Value
Next
ElseIf Cells(Target.Row, 1).Value = 1 Then
sonsat = Cells(Rows.Count, 2).End(3).Row + 1
For a = 11 To 20
Cells(sonsat, a).Value = Cells(Target.Row, a).Value
Cells(Target.Row, a).Value = ""
Next
End If
End Sub

 

[ahzola]

Ben işlemi a sutununa yazınca b den F ye kadar olan satırları kopyalaması için yapmiştım sizin dosyada k ile başlıyor devam ediyor.

For i = 11 to 20 ve for a=11 to 20 kodarda 11 sutun yani "K" sutunundan başla 20 sutuna kadar kopyala anlamındadır eğer sizin dosyanızda gizlediğiniz satırlarda B ile K arasındakilerde veri varsa ve kopyalamasını veya aşağı taşımasını istiyorsanız For =2 to 20 yapın..

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A1:A65536]) Is Nothing Then Exit Sub
If Cells(Target.Row, 1).Value = 0 Then
Rows(Target.Row + 1).Insert
On Error Resume Next
For i = 11 To 20
Cells(Target.Row + 1, i).Value = Cells(Target.Row, i).Value
Next
ElseIf Cells(Target.Row, 1).Value = 1 Then
sonsat = Cells(Rows.Count, 2).End(3).Row + 1
For a = 11 To 20
Cells(sonsat, a).Value = Cells(Target.Row, a).Value
Cells(Target.Row, a).Value = ""
Next
End If
End Sub

Değil Hüseyin bey;

satır genişliğini benden biraz daha iyi bilen bir arkadaşın
yardımı ile aştım.
Formüllerde sorun çıkıyor kopyalarken.
Taşıma/ kaydırma olayında ise şuursuz haraket ediyor.
100 150 satırlara taşıyor verileri arada uçuk boşluklar oluşuyor
oysaki veri olan en alt satırın altına taşıması gerekiyor.
buna mükabil ekledim dosyayı.

 

[Huseyinkis]

Ekteki kodlarla tekrar denermisin.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A1:A65536]) Is Nothing Then Exit Sub
If Cells(Target.Row, 1).Value = "" Then
ElseIf Cells(Target.Row, 1).Value = 0 Then
Rows(Target.Row + 1).Insert
For i = 11 To 20
Cells(Target.Row + 1, i).Value = Cells(Target.Row, i).Value
Next i

ElseIf Cells(Target.Row, 1).Value = 1 Then
sonsat = Cells(Rows.Count, 11).End(3).Row + 1

For a = 11 To 20
Cells(sonsat, a).Value = Cells(Target.Row, a).Value
Cells(Target.Row, a).Value = ""
Next a

End If
End Sub

 

[ahzola]

Günaydınlar;

Hüseyin bey 1 hiç tepki vermiyor.
0 kendinden sonraki satırı boşaltıyor.
yani boş satır kopyalıyor.

 

[Huseyinkis]

Günaydınlar;

Hüseyin bey 1 hiç tepki vermiyor.
0 kendinden sonraki satırı boşaltıyor.
yani boş satır kopyalıyor.

Ekli dosyayı incelermisiniz.

 

[ahzola]

Merhabalar;

Emeğiniz için teşekkür ederim Hüseyin bey,
ellerineze sağlık.
Taşıma ve kopyalama işlemi muntazam çalışıyor. ok
Lakin taşınan ve kopyalanan sütunlarda formüller kayboluyor.

 

[ahzola]

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A1:A65536]) Is Nothing Then Exit Sub
If Cells(Target.Row, 1).Value = "" Then
ElseIf Cells(Target.Row, 1).Value = 0 Then
Rows(Target.Row + 1).Insert
For i = 11 To 20
Cells(Target.Row + 1, i).Value = Cells(Target.Row, i).Value
Next i

ElseIf Cells(Target.Row, 1).Value = 1 Then
sonsat = Cells(Rows.Count, 11).End(3).Row + 1

For a = 11 To 20
Cells(sonsat, a).Value = Cells(Target.Row, a).Value
Cells(Target.Row, a).Value = ""
Next a

End If
End Sub



Selamlar;
yukarıdaki makromuz formülleri taşıma ve kopyalama yapmıyor.
Formülleridemi makro ile yazmak gerek nasıl çözüme kavuşturacağız
sorunu yardımlarınızı esigemiyiniz lütfen değerli arkadaşlar.

 

[Huseyinkis]

Yazıyı geç gordum ozur dilerim kodları aşağıdaki gibi değiştirin sorunu çozecektir.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A1:A65536]) Is Nothing Then Exit Sub
If Cells(Target.Row, 1).Value = "" Then
ElseIf Cells(Target.Row, 1).Value = 0 Then
Rows(Target.Row + 1).Insert
For i = 11 To 20
Cells(Target.Row + 1, i).Value = Cells(Target.Row, i).Formula
Next i

ElseIf Cells(Target.Row, 1).Value = 1 Then
sonsat = Cells(Rows.Count, 11).End(3).Row + 1

For a = 11 To 20
Cells(sonsat, a).Value = Cells(Target.Row, a).Formula
Cells(Target.Row, a).Value = ""
Next a

End If
End Sub

 

[ahzola]

Teessüf ederim lütfen ne özürü
Hüseyin Bey yaptığınız yardımlar
için ne kadar teşekkür etsem azdır.
aşağıdaki linkte yardım istemiştim. sağolsun
arkadaşım eğildi mevzuuya yalnız bende kod çalışmadı
şimdi 2007 yükledim. 2 3 gündür beynim sulandı resmen
acemi olunca herşey çok zor oluyor inanın. bilahare
buna bakacağım. Zaten istediğim bütün yardımlar
kendimce yapmaya çalıştığım bir çalışmanın parçaları
dolayısı ile öncelik olarak aşağıdaki konuyu halletmem gerek
şayet vaktiniz olduğunda bakabilirseniz minnettar olurum inanın.
iyi günelr dilerim herşey gönlünüzce olsun.

 

[ahzola]

Selamlar;
Ancak dönebildim.

Hüseyin Bey;
Formülleri kopyalıyor lakin formüller işlevini yapmıyor.
Şöyleki.

=EĞER(O5="";"";(EĞER(M5<>5;O5;EĞER(M5=5;O5*75%;" "))))
yukarıdaki formülü alt satırlara yine aynı değerlerle kopyalıyor/taşıyor

M5 O5 gibi oysa alta kopya/taşıma yaptıkça M6 O6 M20 O20
gibi satır nolarınında değişmesi lazım. Tekrar bakabilirseniz çok sevineceğim.

 

[Huseyinkis]

Ekteki Kodları denermisiniz Kopyala yapıştır işlemi cozum bulmaya çalıştım.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A1:A65536]) Is Nothing Then Exit Sub
If Cells(Target.Row, 1).Value = "" Then
ElseIf Cells(Target.Row, 1).Value = 0 Then
Rows(Target.Row + 1).Insert
Range(Cells(Target.Row, 11), Cells(Target.Row, 20)).Copy
Cells(Target.Row + 1, 11).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Cells(Target.Row, 1).Select
ElseIf Cells(Target.Row, 1).Value = 1 Then
sonsat = Cells(Rows.Count, 11).End(3).Row + 1
Range(Cells(Target.Row, 11), Cells(Target.Row, 20)).Copy
Cells(sonsat, 11).Select
ActiveSheet.Paste
Range(Cells(Target.Row, 11), Cells(Target.Row, 20)).ClearContents
Application.CutCopyMode = False
Cells(Target.Row, 1).Select
End If
End Sub