Zemin Rengi Değiştirilen Satırı Diğer Sayfaya Taşıma

[sumer2003]

Merhaba Arkadaşlar;

Excelde KDV kontrolü yaparken kontrol ettiğim satırların dolgu rengini sarıya boyamak suretiyle işaretliyorum.

İşaretleme işlemi bittiği anda ilgili satırı nasıl diğer sayfaya otomatik olarak taşıyabilirim?

 

[Ömer]

Merhaba,

Sayfa1 A sütununda zemini renkli olan hücreleri, Sayfa2 A sütununa listeler.

Sub Zemin_Rengi()
    
    Dim i As Long, sat As Long, S2 As Worksheet
    
    Set S2 = Sheets("Sayfa2")
    
    Application.ScreenUpdating = False
    Sheets("Sayfa1").Select
    S2.Range("A2:A" & Rows.Count).ClearContents
    
    sat = 2
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        If Cells(i, "A").Interior.ColorIndex > 0 Then
            S2.Cells(sat, "A") = Cells(i, "A")
            sat = sat + 1
        End If
    Next i
    
    Application.ScreenUpdating = True
    
End Sub

.

 

[Ömer BARAN]

Merhaba.

Alternatif ve bir görüş.

Bence dolgu rengi üzerine işlem yapmak yerine,
diğer sayfaya aktarılacak satırda herhangi bir hücreye (alan sınırlaması aşağıda belirtildi) çift tıkladığınızda
diğer sayfaya kopyalama yaptırmak daha pratik ve anlamlı.

Aşağıdaki kodu, alt taraftan üzerinde çalıştığınız sayfanın adına fareyle sağ tıkaladığınızda açılacak VBA ekranında sağdaki boşluğa yapıştırın.

Kod;
-- Üzerinde çalıştığınız sayfanın F2:M100 aralığındaki bir hücreye fareyle çift tıkladığınızda devreye girer,
-- Çift tıkladığınız hücrenin bulunduğu satırdaki A:K sütun aralığını kopyalar,
-- Sayfa2 isimli sayfada, C sütunundaki ilk boş satıra yapıştırır.

Kod'da renk eşleşmelerini takip ederseniz, kodun çalışacağı hücre aralığını,
kopyalanacak sütun aralığını ve yapıştırılacak sütunu isteğinize göre değiştirebilirsiniz.
.

[B]Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
[/B]If Intersect(Target, [[B][SIZE="4"]F2:M100[/SIZE][/B]]) Is Nothing Then Exit Sub
Range("[B][COLOR="red"][SIZE="4"]A[/SIZE][/COLOR][/B]" & Target.Row & "[B][COLOR="red"][SIZE="4"]:K[/SIZE][/COLOR][/B]" & Target.Row).Copy
Sheets("[B][COLOR="DarkOrange"]Sayfa2[/COLOR][/B]").Range("[B][COLOR="Blue"][SIZE="4"]C[/SIZE][/COLOR][/B]" & Sheets("[B][COLOR="DarkOrange"]Sayfa2[/COLOR][/B]").Cells(Rows.Count, "[B][COLOR="blue"][SIZE="4"]C[/SIZE][/COLOR][/B]").End(3).Row + 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False: Cancel = True
[B]End Sub[/B]

 

[EGULERYUZ]

Merhaba,

Sayfa1 A sütununda zemini renkli olan hücreleri, Sayfa2 A sütununa listeler.

Sub Zemin_Rengi()
  
    Dim i As Long, sat As Long, S2 As Worksheet
  
    Set S2 = Sheets("Sayfa2")
  
    Application.ScreenUpdating = False
    Sheets("Sayfa1").Select
    S2.Range("A2:A" & Rows.Count).ClearContents
  
    sat = 2
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        If Cells(i, "A").Interior.ColorIndex > 0 Then
            S2.Cells(sat, "A") = Cells(i, "A")
            sat = sat + 1
        End If
    Next i
  
    Application.ScreenUpdating = True
  
End Sub

.

Ömer bey bu kodu A sutunundan E sutununa kadar olan sutunlar için düzenleyemedim yardımcı olurmusunuz?Birde taşıdıktan sonra
sayfa1 deki satırın verilerini temizleyebilirmi.şimdiden teşekkürler..

 

[Ömer]

A:E arasının şarta uyan verilerinin listelemesi diğer sayfada nasıl olacak?

 

[EGULERYUZ]

     
     

 

[EGULERYUZ]

AYNI SIRA İLE A,B,C,D,E SUTUN OLARAK

 

[EGULERYUZ]

A:E arasının şarta uyan verilerinin listelemesi diğer sayfada nasıl olacak?

Ömer bey aynı sıra ile olacak A;B;C;D;F sutun olarak

 

[Ömer]

Deneyiniz.

Sub Zemin_Rengi()
    
    Dim i As Range, sat As Long, S2 As Worksheet, son As Long
    
    Set S2 = Sheets("Sayfa2")
    
    Application.ScreenUpdating = False
    Sheets("Sayfa1").Select
    S2.Range("A2:E" & Rows.Count).ClearContents
    son = [A:E].Find("*", , , , xlByRows, xlPrevious).Row
    
    For Each i In Range("A2:E" & son)
        If i.Interior.ColorIndex > 0 Then
            sat = S2.Cells(Rows.Count, i.Column).End(xlUp).Row + 1
            If sat < 2 Then sat = 2
            S2.Cells(sat, i.Column) = i.Value
            i.Clear
        End If
    Next i
    
    Application.ScreenUpdating = True
    
End Sub

 

[EGULERYUZ]

Deneyiniz.

Sub Zemin_Rengi()
   
    Dim i As Range, sat As Long, S2 As Worksheet, son As Long
   
    Set S2 = Sheets("Sayfa2")
   
    Application.ScreenUpdating = False
    Sheets("Sayfa1").Select
    S2.Range("A2:E" & Rows.Count).ClearContents
    son = [A:E].Find("*", , , , xlByRows, xlPrevious).Row
   
    For Each i In Range("A2:E" & son)
        If i.Interior.ColorIndex > 0 Then
            sat = S2.Cells(Rows.Count, i.Column).End(xlUp).Row + 1
            If sat < 2 Then sat = 2
            S2.Cells(sat, i.Column) = i.Value
            i.Clear
        End If
    Next i
   
    Application.ScreenUpdating = True
   
End Sub

Ömer bey çok teşekkürler

 

[EGULERYUZ]

@Ömer bey merhaba kod çok iyi çalışıyor fakat sayfa ikiye aktarınca alt alta yazmıyor eski veriyi silip üzerine yazıyor
kodu bu doğrultuda düzeltebilirmiyiz zahmet olmazsa...şimdiden teşekkür ederim

 

[Ömer]

Kodlarda aşağıdaki satırı silerseniz eski verileri silmeden aktarım yapar.

S2.Range("A2:E" & Rows.Count).ClearContents

.

 

[EGULERYUZ]

Kodlarda aşağıdaki satırı silerseniz eski verileri silmeden aktarım yapar.

S2.Range("A2:E" & Rows.Count).ClearContents

.

çok teşekkürler

 

[ismail44]

Merhaba,

Sayfa1 A sütununda zemini renkli olan hücreleri, Sayfa2 A sütununa listeler.

Sub Zemin_Rengi()
   
    Dim i As Long, sat As Long, S2 As Worksheet
   
    Set S2 = Sheets("Sayfa2")
   
    Application.ScreenUpdating = False
    Sheets("Sayfa1").Select
    S2.Range("A2:A" & Rows.Count).ClearContents
   
    sat = 2
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        If Cells(i, "A").Interior.ColorIndex > 0 Then
            S2.Cells(sat, "A") = Cells(i, "A")
            sat = sat + 1
        End If
    Next i
   
    Application.ScreenUpdating = True
   
End Sub

.

Hocam bende tam tersini yapmak istiyorum renklendirdiğim satırları diğer sayfaya gelmesini istemiyorum mümkün müdür

 

[Ömer]

Merhaba,

If Cells(i, "A").Interior.ColorIndex > 0 Then

yerine aşağıdaki yazıp deneyiniz.

If Cells(i, "A").Interior.ColorIndex = xlNone Then