• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

S

sumer2003

Katılım
27 Eylül 2007
Mesajlar
21
Excel Vers. ve Dili
Microsoft Office 2010
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?
 
Merhaba,

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

Kod: 
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

.
 
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.
.
Kod: 
[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]
 
Ömer' Alıntı:
Merhaba,

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

Kod: 
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

.
Genişletmek için tıkla ...
Ö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..
 
Son düzenleme:
A:E arasının şarta uyan verilerinin listelemesi diğer sayfada nasıl olacak?
 
[TR][TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD][/TR]
[TR][TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD][/TR]
 
Deneyiniz.
Kod: 
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' Alıntı:
Deneyiniz.
Kod: 
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
Genişletmek için tıkla ...
Ömer bey çok teşekkürler
 
@Ö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
 
Kodlarda aşağıdaki satırı silerseniz eski verileri silmeden aktarım yapar.

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

.
 
Ömer' Alıntı:
Merhaba,

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

Kod: 
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

.
Genişletmek için tıkla ...
Hocam bende tam tersini yapmak istiyorum renklendirdiğim satırları diğer sayfaya gelmesini istemiyorum mümkün müdür
 
Merhaba,

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

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

If Cells(i, "A").Interior.ColorIndex = xlNone Then
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst