Başka sayfaya satır taşıma

[sedsa]

Merhaba;
Ekli dosya da belirtiğim gibi ilk sayfada H7 hücresine değer girdiğimde ilk sayfadan (alttaki satırları bir üste çıkacak) silip ikinci sayfaya taşımanı istiyorum.bunu her H sütununa değer girdikçe ikinci sayfadaki satırlara alt alta işlenmesi gerekmektedir.
Yardımlarınız için şimdiden teşekkürler.

 

[asi_kral]

Merhaba
Sayfanın kod bölümüne kopyalayın ve deneyin.

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim S1 As Worksheet, STR As Long
Dim ÇLŞ As Variant, SÇLŞ As Variant
Application.ScreenUpdating = False
Application.EnableEvents = False
If Intersect(Target, Range("H:H")) Is Nothing Then _
Application.ScreenUpdating = True: _
Application.EnableEvents = True: Exit Sub
If Target <> Empty Then
Set S1 = Sheets("TAMAMLANAN SİPARİŞLER")
STR = S1.Range("B" & Rows.Count).End(xlUp).Row + 1
If STR < 7 Then
STR = 7
End If
Range("B" & Target.Row & ":H" & Target.Row).Copy _
S1.Range("B" & STR)
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

 

[sedsa]

İlginiz teşekkür ederim ama malasef çalıştıramadım

 

[asi_kral]

İlginiz teşekkür ederim ama malasef çalıştıramadım

Çalıştıramadığınız dosyanızı bir ekleyin de bakalım.

 

[sedsa]

Çalıştıramadığınız dosyanızı bir ekleyin de bakalım.

ekledim üstad

 

[asi_kral]

210'uncu satırdaki verileri silin isterseniz.
Veri satır ararken o satırı dolu gördüğü için onun altına aktarım yapıyor

 

[sedsa]

üstad tamam anladım taşıma işi gerçekleşiyor ellerine sağlık ama sipariş takip planı sayfasından o satırı silip aşağıdaki satırları yukarı alması gerekiyor.

 

[asi_kral]

üstad tamam anladım taşıma işi gerçekleşiyor ellerine sağlık ama sipariş takip planı sayfasından o satırı silip aşağıdaki satırları yukarı alması gerekiyor.

Kusura bakmayın bu noktayı atlamışım

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim S1 As Worksheet, STR As Long
Dim ÇLŞ As Variant, SÇLŞ As Variant
Application.ScreenUpdating = False
Application.EnableEvents = False
If Intersect(Target, Range("H:H")) Is Nothing Then _
Application.ScreenUpdating = True: _
Application.EnableEvents = True: Exit Sub
If Target <> Empty Then
Set S1 = Sheets("TAMAMLANAN SİPARİŞLER")
STR = S1.Range("B" & Rows.Count).End(xlUp).Row + 1
If STR < 7 Then
STR = 7
End If
Range("B" & Target.Row & ":H" & Target.Row).Copy _
S1.Range("B" & STR)
Application.DisplayAlerts = False
Range("B" & Target.Row & ":H" & Target.Row).Delete xlUp
Application.DisplayAlerts = True
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Bunu kullanın.

 

[sedsa]

Çok teşekkür ederim ellerinize sağlık...

 

[asi_kral]

Çok teşekkür ederim ellerinize sağlık...

Kolay Gelsin.