• DİKKAT

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

Renkli aktar

Sorunu anlaşılır değil maalesef. Hangi sayfadaki hangi verilerin hangi şartla nereye aktarılacağını daha ayrıntılı belirtirseniz iyi olur.
 
Merhaba sayın Yusuf44 aslında örnek dosyam işelmin bitmiş hali,Tüm parçalar sayfasında "B"
sütunundaki yeşile boyanmış satırları "DEFECTİFE" sayfasındaki gibi aktarmak istiyorum "DEFECTİFE" sayfasını şu anki hali boşken, bunu makro ile yapmak bana büyük verilerde zaman çok zaman kazandıracak,
örnek:TÜM PARÇALAR sayfasında "B" sütunundaki yeşile boyalı satırları filtrele
DEFECTİFE sayfasını seç aktar gibi kolay gelsin teşekkürler..
 
Makro kaydet yöntemini denediniz mi? Makro kaydetmeyi başlatın ve bu işlemleri sırasıyla yapıp kaydetmeyi durdurun.
 
Sayın Yusuf44 satırlar değişken bu yüzden makro kaydet ile çözüm olmuyor.
 
Merhaba
Sayfaya bir buton ekleyerek; incelermisiniz?

http://s6.dosya.tc/server4/4xlpkr/RENKLIAKTAR.zip.html

Kod: 
Private Sub CommandButton1_Click()
Dim Topla As Double
Dim s1, s2 As Worksheet
Dim x, i As Long, c, d, e, f As Range
Dim k, v
 Set s1 = Sheets("DEFECTİVE")
 Set s2 = Sheets("TÜM PARÇALAR")
  x = s2.Cells(Rows.Count, "b").End(3).Row
  i = s1.Cells(Rows.Count, "b").End(3).Row
With s2.Range("b1:b" & x)
   Application.FindFormat.Interior.ColorIndex = 10
   Set c = .Find(What:="", SearchFormat:=True)
If Not c Is Nothing Then
        Set d = c
        Do
 k = 1
v:
Set e = s1.Range("b" & k & ":b" & i).Find(s2.Cells(d.Row, "b").Value)
If Not e Is Nothing Then
If s1.Cells(e.Row, "a").Value <> s2.Cells(d.Row, "a").Value Then k = e.Row + 1: GoTo v
s1.Cells(e.Row, "c") = s1.Cells(e.Row, "c") + s2.Cells(d.Row, "c")
Else
    Set f = s1.Range("a1:a" & i).Find(s2.Cells(d.Row, "a").Value)
    If Not f Is Nothing Then
    s1.Range("A" & f.Row + 1 & ":C" & f.Row + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    s1.Range("A" & f.Row + 1 & ":C" & f.Row + 1).Value = s2.Range("A" & d.Row & ":C" & d.Row).Value
'................deneme bölümü
    s1.Range("B" & f.Row + 1).Interior.ColorIndex = 4
 '..........................................................
    i = s1.Cells(Rows.Count, "b").End(3).Row
    Else
    i = i + 2
    s1.Range("A" & i & ":C" & i).Value = s2.Range("A" & d.Row & ":C" & d.Row).Value
    MsgBox s1.Name & " Sayfasında part number " & vbCrLf & i & "'nci satıra Yoktu; eklendi"
    End If
End If
s2.Cells(d.Row, "c") = 0
  Set d = .Find(What:="", After:=d, SearchFormat:=True)
  Loop Until d.Address = c.Address
End If
End With
Application.FindFormat.Clear
End Sub
 
Son düzenleme:
Merhaba sayın plint öncelikle çok teşekkür ederim sonuç iyi isteğim olması için bir kaç düzeltme gerekli,size tekrar bir örnek ekliyorum,kırmızı ile renklendirdiğim satırlar TÜM PARÇALAR sayfasında
yeşil renkli iken DEFECTİFE sayfasında renksiz geliyor,birde TÜM PARÇALAR sayfasında "C" sütunundaki değerler silinmemeli,ve aktarılan değerlerde başlıklar da gelmeli "asus part number"
yazan değerler olmalı yani, ve en sonunda en alt satırlarda toplam değerler olmalı,
yani özetle:TÜM PARÇALARDAKİ DEĞERLER YEŞİL RENKLİ HÜCRELER FİLTRELENİP,BAŞLIKLAR VE ALT TOPLAMLARI İLE AKTARILMALI KOLAY GELSİN TEŞEKKÜRLER..
http://www.dosya.tc/server5/i6l6i4/RENKLIAKTAR.xls.html
 
ADER_34' Alıntı:
TÜM PARÇALARDAKİ DEĞERLER YEŞİL RENKLİ HÜCRELER FİLTRELENİP,BAŞLIKLAR VE ALT TOPLAMLARI İLE AKTARILMALI KOLAY GELSİN TEŞEKKÜRLER..
Genişletmek için tıkla ...
Biraz daha açıklarsanız,
Yani "DEFECTİFE sayfasında" ki "c" sütunundaki verilere eklenmeyecek,
-filtrelenenler ilgili sayfanın son dolu satırı altına aktarılacak gibimi?
yada
-ilgili sayfa boşaltılacak filtrelenenler boş sayfaya aktarılacak gibimi?

Bu şekilde ise
http://www.dosya.tc/server5/v39sud/RENKLIAKTAR2.zip.html
(Eğer eskiler silinmeden, alt satırlara taşınacaksa; kırmızı bölümü silersiniz.)
Kod: 
Private Sub CommandButton1_Click()

 Set s1 = Sheets("DEFECTİVE")
 Set s2 = Sheets("TÜM PARÇALAR")
 s2.Activate
 Application.ScreenUpdating = False
  i = s1.Cells(Rows.Count, "b").End(3).Row
  [COLOR="Red"]s1.Rows("1:" & i).Delete[/COLOR]
      x = s2.Cells(Rows.Count, "b").End(3).Row
  s2.Range("A1:A" & x).SpecialCells(xlCellTypeConstants, xlValue).Rows.Hidden = True
With s2.Range("b1:b" & x)
   Application.FindFormat.Interior.ColorIndex = 10
   Set c = .Find(What:="", SearchFormat:=True)
If Not c Is Nothing Then
        Set d = c
        Do
 Rows(d.Row).Hidden = False
  Set d = .Find(What:="", After:=d, SearchFormat:=True)
  Loop Until d.Address = c.Address
End If
End With
  i = s1.Cells(Rows.Count, "b").End(3).Row
Application.FindFormat.Clear
s2.Range("A1:c" & x).SpecialCells(xlCellTypeVisible).Copy
s1.Range("a" & i + 1).PasteSpecial
Application.ScreenUpdating = True
Application.CutCopyMode = False
i = s1.Cells(Rows.Count, "b").End(3).Row
For a = 1 To i
If s1.Cells(a, "b").Value <> "Total" Then
t = s1.Cells(a, "c") + t
Else
s1.Cells(a, "c") = t
t = 0
End If
Next
s2.Rows.Hidden = False
End Sub
 
Son düzenleme:
Günaydın Sayın plint,kodalr sorunsuz işlem başarılı tam istediğim gibi olmuş ellerinize bilginize sağlık
sadece kodalrı kendi orjinal dosyama uyarladığımda,renk kodunda hata veriyor sizin kullandığınız renk koyu yeşil bir renk bendeki biraz açık bir renk kodalrdaki
"Application.FindFormat.Interior.ColorIndex = 10" yerine 5287936 makro kaydet ile bulduğum bu renk kodunu yazınca hata alıyorum ne yapmalıyım? kolay gelsin..
 
ADER_34' Alıntı:
"Application.FindFormat.Interior.ColorIndex = 10" yerine 5287936 makro kaydet ile bulduğum bu renk kodunu yazınca hata alıyorum ne yapmalıyım? kolay gelsin..
Genişletmek için tıkla ...
Merhaba
Şöylede yapabilirsiniz;
Kod: 
Application.FindFormat.Interior.Color = 5287936
Yukarıdaki renk indexi "14" olmalı
Kod: 
Application.FindFormat.Interior.ColorIndex = 14[COLOR="Red"][/COLOR]

veya renkli hücrenin indexini öğrenmek için:
Kod: 
MsgBox Range("B2").Interior.ColorIndex
yada
Makro kaydettede "Bul ve Değiştir" penceresinden "Biçim\Hücreden biçim seç"
ile bulabilirsiniz.
Hayırlı çalışmalar dilerim, kolay gelsin.
 
Son düzenleme:
Selam sayın plint çok çok teşekkür ederim,dediklerinizi yaptım sonuç sorunsuz,tek bir şey daha sormak istiyorum,ben hücreleri Koşullu biçimlendirme ile formül kullanarak yapıp aynı rengi kullandığımda da sorun oluyor ama formül kullanmadan tek tek renklendirince sorun yok
formül =EĞERSAY(MB;B2)>0 şeklinde bir formül bu sorunu nasıl aşarım kolay gelsin teşekürler..
 
Merhaba
Koşullu biçimlendirme ile renkleniyorsa kodlar çalışmayacaktır, komple değişmek lazım
o haliyle bir örnek dosya eklermisiniz? "TÜM PARÇALAR" sayfasında en fazla kaç satır oluyor.?
"C" sütunundaki "1" ve "0" lar da koşullumu?
Yani renkli olmayan "b" satırının karşısında ("c" sütununda) "0" dan büyük sayı olma ihtimali varmı?
Eğer yoksa kodları "c" sütununa göre uyarlamak kolay olur.

Şöyle;
Kod: 
Private Sub CommandButton1_Click()
 Set s1 = Sheets("DEFECTİVE")
 Set s2 = Sheets("TÜM PARÇALAR")
 a = s2.Cells(Rows.Count, "b").End(3).Row
 Application.Calculation = xlCalculationManual
 Application.ScreenUpdating = False
   i = s1.Cells(Rows.Count, "b").End(3).Row
  s1.Rows("1:" & i).Delete
s2.Range("c1:c" & a).Replace What:="0", Replacement:="A", LookAt:=xlWhole
Columns("C:C").SpecialCells(xlCellTypeConstants, 2).Rows.Hidden = True
s2.Range("A1:c" & a).SpecialCells(xlCellTypeVisible).Copy
  i = s1.Cells(Rows.Count, "b").End(3).Row
s1.Range("a" & i + 1).PasteSpecial
Application.CutCopyMode = False
s2.Rows.Hidden = False
 Application.ScreenUpdating = True
 s2.Range("c1:c" & a).Replace What:="A", Replacement:=0, LookAt:=xlWhole
 i = s1.Cells(Rows.Count, "b").End(3).Row
For a = 1 To i
If s1.Cells(a, "b").Value <> "Total" Then
If s1.Cells(a, "a") <> "" Then s1.Cells(a, "b").Interior.ColorIndex = 14
If s1.Cells(a, "b").Interior.ColorIndex <> 14 And s1.Cells(a, "b") <> "" Then s1.Cells(a, "b").Interior.ColorIndex = 6
t = s1.Cells(a, "c") + t
Else
s1.Cells(a, "b").Interior.ColorIndex = 6
s1.Cells(a, "c") = t
t = 0
End If
Next
Application.Calculation = xlCalculationAutomatic
End Sub
 
Son düzenleme:
Merhaba sayın plint,size bir örnek yüklüyorum,bakarsanız sevinirim,TÜM PARÇALAR,"B" sütununda koşullu biçimlendirme ile renklendirme var."C" sütununda eğersay formülü kullanıyorum ama sonra değerler şeklinde kopyala yapıştır yapıyorum, sayfalar orjinal hali satır sayıları sabit,
kodlarınızı denedim şu satırda hata verdi,
Columns("C:C").SpecialCells(xlCellTypeConstants, 2).Rows.Hidden = True
satırı pasif yapınca" DEFECTİVE" sayfasında filtrelenmeden aktarım oldu
kolay gelsin teşekkürler..
http://s3.dosya.tc/server6/aquvmp/RENKLI_AKTAR_3.xls.html
 
Son düzenleme:
Merhaba
Önceki örneğinizde renksiz "b" hücrelerinin karşısında ("c" de) "0" bulunuyordu kodlar
o şekle dayalı olduğu için hata verdi.

Aşağıdaki kodları deneyin "C" sütununda formülleri değere çevirmenize gerek olmayacaktır.
Dosyanızda ki koşullu biçimlendirmede yeşilin 2 tonu kullanılmış onun için renk olmayanlara bakarak döngü çalışacak.

Kod: 
 If s2.Range("B" & x).DisplayFormat.Interior.ColorIndex <> -4142 And s2.Cells(x, "b").Interior.ColorIndex <> 6 Then
Renk bulunmayan satırların "c" sütunu "0" olduğuna göre: Toplamlar (Total) satırı olduğu gibi aktarılacak; koda gerek görünmüyor.
Şöyle deneyinin.
Kod: 
Sub aktar()
Dim s1, s2 As Worksheet
Dim i, a, x, x2
 Set s1 = Sheets("DEFECTİVE")
 Set s2 = Sheets("TÜM PARÇALAR")
 a = s2.Cells(Rows.Count, "b").End(3).Row
 Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
i = s1.Cells(Rows.Count, "b").End(3).Row
  s1.Rows("1:" & i).Delete
For x = 1 To a
If s2.Cells(x, "b").Interior.ColorIndex = 6 Then
x2 = x2 + 1
s1.Range("a" & x2 & ":c" & x2).Value = s2.Range("a" & x & ":c" & x).Value
s1.Cells(x2, "b").Interior.ColorIndex = 6
If s2.Cells(x + 1, "b").Value = "" Then x2 = x2 + 1
End If
If s2.Range("B" & x).DisplayFormat.Interior.ColorIndex <> -4142 And s2.Cells(x, "b").Interior.ColorIndex <> 6 Then
x2 = x2 + 1
s1.Range("a" & x2 & ":c" & x2).Value = s2.Range("a" & x & ":c" & x).Value
s1.Range("B" & x2).Interior.ColorIndex = 50
End If
Next
s1.Range("a1:c" & x2 - 1).Borders.Weight = xlThin

[COLOR="Red"] Application.Calculation = xlCalculationAutomatic
 Application.ScreenUpdating = true[/COLOR]
End Sub
 
Son düzenleme:
Sayın plint tek kelime ile muhteşem kodlar sorunsuz çalışıyor,elinize biliginize sağlık, çok çok teşekkür ederim Allah razı olsun sizden,hayırlı geceler kolay gelsin..
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst