bir sayfadaki satırı diğer sayfaya taşıyan makro

[darksimoon]

Arkadaşlar merhaba;
elimde bir veri listesi var. (DATA sheet) listenin sonundaki hücreye (Y sütunu) CLOSED değerini girince tüm satırın kesilip diğer sayfadaki (DONE sheet) ilk boş satıra aktarılmasını istiyorum.
böylece güncel ve biten verilerimi ayrı sayfalarda toplayabileceğim.

bununla ilgili yaptığım araştırmaya göre dosyamı oluşturdum. (ekteki dosya)
ama pratikte yolunda gitmeyen şeyler var;
1- Y2 sütununa girdiğim her CLOSED değeri çalışmıyor. sütundaki her hücrede çalışsın istiyorum.
2- DONE sekmesine aktarım ancak A3 satırından itibaren oluyor. oysa ben A2 den itibaren yazılsın istiyorum.

rica etsem ilgili kodları inceleyip düzeltebilir misiniz ? böylece örnek bir dosyamız da olmuş olur.

 

[asi_kral]

Arkadaşlar merhaba;
elimde bir veri listesi var. (DATA sheet) listenin sonundaki hücreye (Y sütunu) CLOSED değerini girince tüm satırın kesilip diğer sayfadaki (DONE sheet) ilk boş satıra aktarılmasını istiyorum.
böylece güncel ve biten verilerimi ayrı sayfalarda toplayabileceğim.

bununla ilgili yaptığım araştırmaya göre dosyamı oluşturdum. (ekteki dosya)
ama pratikte yolunda gitmeyen şeyler var;
1- Y2 sütununa girdiğim her CLOSED değeri çalışmıyor. sütundaki her hücrede çalışsın istiyorum.
2- DONE sekmesine aktarım ancak A3 satırından itibaren oluyor. oysa ben A2 den itibaren yazılsın istiyorum.

rica etsem ilgili kodları inceleyip düzeltebilir misiniz ? böylece örnek bir dosyamız da olmuş olur.

Merhaba
Boş bir module kopyalayın ve deneyin.

Option Explicit
Sub verileri_taşı_1967()
'Konu       :   Yazılan Bilgiye Göre Aktarım
'Mail       :   m.batu.1967@gmail.com
'Msn        :   m.batu.1967@hotmail.com.tr
'Coder By   :   asi_kral_1967
Dim asi As Worksheet, kral As Worksheet, _
a As Range, b As Variant, c As Long
Application.ScreenUpdating = False
Set asi = Sheets("DATA"): Set kral = Sheets("DONE")
kral.Range("A2:Y" & Rows.Count).ClearContents
c = 2
Set a = asi.Range("Y:Y").Find("CLOSED", , , xlWhole)
If Not a Is Nothing Then
b = a.Address
Do
asi.Range("A" & a.Row & ":Y" & a.Row).Copy _
Destination:=kral.Range("A" & c)
c = c + 1
Set a = asi.Range("Y:Y").FindNext(a)
Loop While Not a Is Nothing And a.Address <> b
End If
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı", vbInformation, "asi_kral_1967"
End Sub

Dosyanız Ekte.

 

[darksimoon]

sayın asi_kral_1967,
ilginiz için teşekkür ederim. gönderdiğiniz dosyayı kontrol ettim.
aktar düğmesinin yeri sanırım yanlışlıkla DONE sekmesinde olmuş. bir de DATA sekmesindeki bir satırı DONE sekmesine aktarılınca DATA daki satırın komple silinmesi gerekiyor. ama burada veri aynen yerinde kalıyor.

 

[asi_kral]

sayın asi_kral_1967,
ilginiz için teşekkür ederim. gönderdiğiniz dosyayı kontrol ettim.
aktar düğmesinin yeri sanırım yanlışlıkla DONE sekmesinde olmuş. bir de DATA sekmesindeki bir satırı DONE sekmesine aktarılınca DATA daki satırın komple silinmesi gerekiyor. ama burada veri aynen yerinde kalıyor.

Üstteki mesajınızda bunlardan bahsetmemiştiniz. Şimdi tekrardan kodlarla mı oynayalım tek seferde söylemiş olsaydınız keşke bunları

 

[darksimoon]

kusura bakmayın. gönderdiğim dosyada zaten kod mevcut. ve mevcut olan kod anlattığım şekilde çalışıyor. o yüzden tekrar bahsetmeye gerek görmedim. dosyayı göndermekteki amacım da bu idi. tekrar kusura bakmayın lütfen. bu arada yeri gelmişken ilgili kodları buraya da yazayım...;
====================================================
Sub MoveRows()
Dim rngOrigin As Range, rngDest As Range
Dim i, j As Integer

i = 1: j = 1
Set rngOrigin = Sheets("DATA").Range("Y1")
Set rngDest = Sheets("DONE").Range("A1").Offset(Application.WorksheetFunction.CountA(Sheets("DONE").Range("A:A")))

Do While rngOrigin.Offset(i, 0).Value <> ""
If rngOrigin.Offset(i, 0).Value = "CLOSED" Then
rngOrigin.Offset(i, 0).EntireRow.Copy
Sheets("DONE").Activate
rngDest.Offset(j, 0).Select
ActiveSheet.Paste
Sheets("DATA").Activate
rngOrigin.Offset(i, 0).EntireRow.Delete xlShiftUp
j = j + 1
i = i - 1
End If
i = i + 1
Loop
Application.CutCopyMode = False
End Sub
=========================================

 

[zafer]

Merhaba

Sayın m.batu'nun kodlarından değişik olarak Y sütunundaki herhangi bir satırına CLOSED girdiğinizde kodlar çalışır.

Private Sub Worksheet_Change(ByVal Target As Excel.Range) ile başlayan kodları sildikten sonra
İsterseniz AKTAR makrosunu butona'da bağlayabilirsiniz.

Ekli dosyayı inceleyiniz.

 

[darksimoon]

Merhaba

Sayın m.batu'nun kodlarından değişik olarak Y sütunundaki herhangi bir satırına CLOSED girdiğinizde kodlar çalışır.

Private Sub Worksheet_Change(ByVal Target As Excel.Range) ile başlayan kodları sildikten sonra
İsterseniz AKTAR makrosunu butona'da bağlayabilirsiniz.

Ekli dosyayı inceleyiniz.

zafer bey merhaba, eklediğiniz dosyayı inceledim. şu an için yorumum bundan daha iyisi olamazdı şeklinde. çok teşekkür ediyorum. ihtiyaç duyarsam tekrar sorarım. sağol varol.