• DİKKAT

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

renkli hücreyi aktar sil

A

asilme

Katılım
18 Ekim 2012
Mesajlar
323
Excel Vers. ve Dili
2003 tr
arkadaşlar kolay gelsin form da aradım çok gelişmiş var istediğimi tam bulamadım.
ben sayfa 1 de her hücrede (A-AA sütunları yaklaşık 100 satır) değişik sayı ve rakam var (ab221 veya cd003 gibi) benim istediğim bu hücreye dolgu rengini değiştirdiğimde örn.sarı bu hücre sayfa 2 ye mesale b sütununa alt alt aktarılacak ve sayfa 1 deki değer silinecek.
Bu işlem her boyadığımda da olabilir yada ayrı ayrı bir çok hücreyi boyayıp butonla aktar dediğimde sayfa 2 ye alt alta aynı sütuna aktarılabilir.
Bana yardımcı olmanız mümkün mü şimdiden teşekkürler,kolay gelsin
 
Merhaba,

Sorunuzu destekleyen küçük bir örnek dosya eklermisiniz.

www.dosya.tc

.
 
Bu şekilde deneyin.

Renkli olanları diğer sayfaya aktarmak için:

Kod: 
Sub Renkli_Aktar() 'renki olan verileri aktarır
        
    Dim Sv As Worksheet, Wf As WorksheetFunction
    Dim i As Byte, j As Long, sat As Long, son As Long
    
    Set Sv = Sheets("VERİLEN PLAKA")
    Set Wf = WorksheetFunction
    
    Application.ScreenUpdating = False
    Sheets("BOŞ PLAKA").Select
    Sv.Range("B2:B" & Rows.Count).Clear
    
    sat = 2
    For i = 2 To 21
        son = Cells(Rows.Count, i).End(xlUp).Row + 1
        If Wf.CountA(Cells(3, i).Resize(son, 1)) > 0 Then
            For j = 3 To son - 1
                If Cells(j, i).Interior.ColorIndex > 0 Then
                    Cells(j, i).Copy Sv.Cells(sat, "B")
                    sat = sat + 1
                End If
            Next j
        End If
    Next i
    
    Application.ScreenUpdating = True
    
End Sub

A sütunundaki verileri tabloya aktarmak için:

Kod: 
Sub Gunluk_Listeyi_Aktar() 'A sütununu tabloya aktarır
        
    Dim i As Byte, c As Range, son As Long
    
    Application.ScreenUpdating = False
    Sheets("BOŞ PLAKA").Select
    Range("B3:U" & Rows.Count).Clear

    For i = 3 To Cells(Rows.Count, "A").End(xlUp).Row
        Set c = [B2:U2].Find(Left(Cells(i, "A"), 1), , xlValues, xlWhole)
        If Not c Is Nothing Then
            son = Cells(Rows.Count, c.Column).End(xlUp).Row + 1
            Cells(i, "A").Copy Cells(son, c.Column)
        Else
            Cells(i, "A").Interior.ColorIndex = 3
            'aktarım sırasında bulamadıklarını kırmızı yapar.
        End If
    Next i
    
    Application.ScreenUpdating = True
    
End Sub

.
 
ömer hocam iki sorun var
1-Diğer sayfaya aktarınca aktardıklarını silmiyor.
2- İkinci makro günlükleri dağıtıyor ancak aynı sayfadaki eski bilgileri siliyor.Normalde onların silinmemesi gerekiyor üzerine eklemesi gerekiyor.

mümkünse kontrol edebilirmisiniz.
 
Bu şekilde deneyin.

Kod: 
Sub Renkli_Aktar() 'renki olan verileri aktarır
        
    Dim Sv As Worksheet, Wf As WorksheetFunction
    Dim i As Byte, j As Long, sat As Long, son As Long
    
    Set Sv = Sheets("VERİLEN PLAKA")
    Set Wf = WorksheetFunction
    
    Application.ScreenUpdating = False
    Sheets("BOŞ PLAKA").Select
    Sv.Range("B2:B" & Rows.Count).Clear
    
    sat = 2
    For i = 2 To 21
        son = Cells(Rows.Count, i).End(xlUp).Row + 1
        If Wf.CountA(Cells(3, i).Resize(son, 1)) > 0 Then
            For j = 3 To son - 1
                If Cells(j, i).Interior.ColorIndex > 0 Then
                    Cells(j, i).Copy Sv.Cells(sat, "B")
                    sat = sat + 1
                    Cells(j, i).ClearContents
                End If
            Next j
        End If
    Next i
    
    Application.ScreenUpdating = True
    
End Sub

Sub Gunluk_Listeyi_Aktar() 'A sütununu tabloya aktarır
        
    Dim i As Byte, c As Range, son As Long
    
    Application.ScreenUpdating = False
    Sheets("BOŞ PLAKA").Select

    For i = 3 To Cells(Rows.Count, "A").End(xlUp).Row
        Set c = [B2:U2].Find(Left(Cells(i, "A"), 1), , xlValues, xlWhole)
        If Not c Is Nothing Then
            son = Cells(Rows.Count, c.Column).End(xlUp).Row + 1
            Cells(i, "A").Copy Cells(son, c.Column)
        Else
            Cells(i, "A").Interior.ColorIndex = 3
            'aktarım sırasında bulamadıklarını kırmızı yapar.
        End If
    Next i
    
    Application.ScreenUpdating = True
    
End Sub


.
 
hocam çok güzel oldu elinize sağlık renkli aktar hücresi aktarınca hücre boş ve dolgu rengi ile kalıyor (boş hücreyi silmiyor yani hücreyi yukarı ötelemiyor) ancak o kadar önemli değil hakkınızı helal edin.
 
Yukarı sürükleyerek silmesi için:

Kod: 
Sub Renkli_Aktar() 'renki olan verileri aktarır
        
    Dim Sv As Worksheet, Wf As WorksheetFunction
    Dim i As Byte, j As Long, sat As Long, son As Long
    
    Set Sv = Sheets("VERİLEN PLAKA")
    Set Wf = WorksheetFunction
    
    Application.ScreenUpdating = False
    Sheets("BOŞ PLAKA").Select
    Sv.Range("B2:B" & Rows.Count).Clear
    
    sat = 2
    For i = 2 To 21
        son = Cells(Rows.Count, i).End(xlUp).Row + 1
        If Wf.CountA(Cells(3, i).Resize(son, 1)) > 0 Then
            For j = (son - 1) To 3 Step -1
                If Cells(j, i).Interior.ColorIndex > 0 Then
                    Cells(j, i).Copy Sv.Cells(sat, "B")
                    sat = sat + 1
                    Cells(j, i).Delete Shift:=xlUp
                End If
            Next j
        End If
    Next i
    
    Application.ScreenUpdating = True
    
End Sub


.
 
hocam mükemmel olmuş hakkınızı helal edin mükemmelsiniz
 
Hakkım varsa helal olsun.
Güle güle kullanın.

.
 
Kolay gelsin dün sorduğum soruya cevap aldın hepinize özellikle Ömer hocama teşekkürler aynı konu aynı işlem ekli dosyayada yapmam gerekiyor nasıl yapabilirim.ilk dosyada 29 harf vardı bu biraz farklı aynı makroyu buna nasıl uygularım yardımlarınız için teşekkürler..
 
Son düzenleme:
Arkadaşlar konunun çözülür çözülmeyeceği konusunda bilgisi olan var sa paylaşabilir mi teşekkürler
 
şuan A sütununa yazan AJ123 yerine 88AJ123 yazınca aynı işlem olurmu
Genişletmek için tıkla ...

1-) 88 leri dikkate almadan harfe göremi aktarma olacak? Aktarırken 88ler kalacak mı silenecek mi?

A harfine ait sütuna atılan bilgiler 88AJ123 gibi bunnlar kendi arasında nasıl dağıtabilirim
Genişletmek için tıkla ...

2-) Bu soru ikinci aşama olacak sanırım. İlk işlemden sonra farklı bir sayfada aktarım istiyorsunuz sanırım. Yalnız örneğinizde "AD" altına DB018-DL398 gibi D ile başlayanları yazmışsınız. Mantığını anlayamadım.

.
 
Ömer' Alıntı:
1-) 88 leri dikkate almadan harfe göremi aktarma olacak? Aktarırken 88ler kalacak mı silenecek mi?



2-) Bu soru ikinci aşama olacak sanırım. İlk işlemden sonra farklı bir sayfada aktarım istiyorsunuz sanırım. Yalnız örneğinizde "AD" altına DB018-DL398 gibi D ile başlayanları yazmışsınız. Mantığını anlayamadım.

.
Genişletmek için tıkla ...
Merhaba Ömer hocam.
Arkadaşın örneklerine benzer birşey sormak istiyorum. Örneğin sayfa1 deki H5:AL97 aralığında eğer renkli hücre varsa sayfa2 ye değeri ve rengi ile beraber kopyalanmasını ve 1. sayfadaki değerlerin aynı kalmasını istiyorum. Kopyalama 1. sayfada hangi hücre neredeyse 2. sayfayada aynı olacak şekilde olması gerekiyor.
 
Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst