Birkaç sutunu yeni sayfaya aktarıp renklendirtme hk.

[balanar]

Merhaba,

Ekteki kısa tuttuğum ama normalde 200-300 satırlık bu şekilde bir dosyamız var. Benim istediğim;

Snap Location rapor sayfasındaki lokasyon kısmına
Snap Time rapor sayfasındaki tarih ve zaman kısmına
Name rapor sayfasındakiad soyad kısmına aktarılıp


Sonra bu rapor sayfasında oluşan yeni listemizde aynı isimli olanlar aynı renklendirmeye sahip olacak şeklinde nasıl yapabilirim?
Atıyorum Erdem SAR'dan 3 tane kayıt var. Erdem SAR'a ait satırların tamamı A b C mavi renkli olacak gibi..


Biliyorum çok zamanınızı alıyorum ama umarım yardımcı olabilecek cıkar..

 

[balanar]

Birde şeyi yazmayı unuttum, rapor sayfasına ad soyad aktarılırken sadece adı soyadı aktarılmalı yani

00299_ERDEM_SAR >> ERDEM SAR olarak yazıcak aradaki _ işareti ve başındaki numarada yok olsun istiyorum

 

[YUSUF44]

Aşağıdaki makroyu deneyiniz. Farklı kişi sayısı 56'dan fazla olursa makro hata verebilir:

Sub rapor()
Set s1 = Sheets("Results")
Set s2 = Sheets("Rapor")
son = s1.Cells(Rows.Count, "A").End(3).Row
s1.Range("A2:A" & son).Copy s2.[A2]
s1.Range("B2:B" & son).Copy s2.[B2]
s1.Range("L2:L" & son).Copy s2.[C2]
Application.CutCopyMode = False
s2.Range("C2:C" & son).TextToColumns Destination:=Range("C2"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
    :="_", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), _
    TrailingMinusNumbers:=True
s2.Range("C2:C" & son).Delete Shift:=xlToLeft
For i = 2 To son
    sut = s2.Cells(i, Columns.Count).End(xlToLeft).Column
    isim = Empty
    For j = 4 To sut
        isim = isim & " " & s2.Cells(i, j)
    Next
    s2.Cells(i, "C") = s2.Cells(i, "C") & isim
    s2.Range(Cells(i, 4), Cells(i, sut)).ClearContents
    If WorksheetFunction.CountIf(s2.Range("C1:C" & i), s2.Cells(i, "C")) = 1 Then
        s2.Range("A" & i & ":C" & i).Interior.ColorIndex = i
    Else
        sat = WorksheetFunction.Match(s2.Cells(i, "C"), s2.Range("C1:C" & i - 1), 0)
        s2.Range("A" & i & ":C" & i).Interior.ColorIndex = s2.Cells(sat, "C").Interior.ColorIndex
    End If
Next
End Sub

 

[balanar]

Run-time error '1004
application defined or object defined error

dedi hocam. Aktardı ama renklendirme vs olmadı.

Birde neden 56'tan fazla olmadıgını sorabilirmiyim

 

[balanar]

Hatayı almamın sebebi makroyu raporlar sayfasına eklemdiğim içinmiş simdi oldu.

Fakat 56'dan fazla yapmam gerekiyor hocam 1000 küsür kişi olabiliyor

 

[YUSUF44]

200-300 satır demiştiniz, 1000 kişi 200-300 satıra nasıl olacak anlamadım.

Bildiğim kadarıyla excelde colorindex değeri en fazla 56 olabiliyor. Yani 56 farklı renk olabiliyor. 1000 küsür kişi demek sizin açıklamanıza göre 1000 küsür farklı renk demektir. Bu kadar çok renkli dosya (eğer o kadar çok renge boyayabilirsek tabi) çok karışık olmaz mı? Ayrıca A kişisinin bir kaydı 2. satırda bir kaydı da 500. satırdaysa bunların aynı renk olması neyi değiştirir?

56'dan fazla olursa baştan başlaması için kodda değişiklik yaptım. Bu türden makroları sayfadan ziyade Modüle kaydetmenizi öneririm:

Sub rapor()
Set s1 = Sheets("Results")
Set s2 = Sheets("Rapor")
son = s1.Cells(Rows.Count, "A").End(3).Row
s1.Range("A2:A" & son).Copy s2.[A2]
s1.Range("B2:B" & son).Copy s2.[B2]
s1.Range("L2:L" & son).Copy s2.[C2]
Application.CutCopyMode = False
s2.Range("C2:C" & son).TextToColumns Destination:=Range("C2"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
    :="_", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), _
    TrailingMinusNumbers:=True
s2.Range("C2:C" & son).Delete Shift:=xlToLeft
For i = 2 To son
    sut = s2.Cells(i, Columns.Count).End(xlToLeft).Column
    isim = Empty
    For j = 4 To sut
        isim = isim & " " & s2.Cells(i, j)
    Next
    s2.Cells(i, "C") = s2.Cells(i, "C") & isim
    s2.Range(Cells(i, 4), Cells(i, sut)).ClearContents
    If WorksheetFunction.CountIf(s2.Range("C1:C" & i), s2.Cells(i, "C")) = 1 Then
        If i Mod 56 = s2.Cells(i - 1, "C").ColorIndex Then
            s2.Range("A" & i & ":C" & i).Interior.ColorIndex = i + 1
        Else
            s2.Range("A" & i & ":C" & i).Interior.ColorIndex = i Mod 56
        End If
    Else
        sat = WorksheetFunction.Match(s2.Cells(i, "C"), s2.Range("C1:C" & i - 1), 0)
        s2.Range("A" & i & ":C" & i).Interior.ColorIndex = s2.Cells(sat, "C").Interior.ColorIndex
    End If
Next
End Sub

 

[balanar]

çok teşekkür ederim

 

[YUSUF44]

Kodu incelerken aklıma geldi, muhtemelen;

i+1

Kısmı

= i Mod 56 +1

Olması gerekiyor.

 

[balanar]

Run time error 438 veriyor hocam

 

[YUSUF44]

Sanıyorum bu hata desteklenmeyen bi işlem yaptırmakla ilgili. Çözümü için hata veren dosyayı görmek gerekir diye düşünüyorum.

 

[balanar]

hocam dediğiniz gibi aşırı veri olunca farklı rengin bi anlamı kalmayacak sizin dediğiniz mantıklı

 

[YUSUF44]

Hatanın medenini bulamadım. Renklendirmeyi iptal etmek için kodun son hali şöyle olur:

Sub rapor()
Set s1 = Sheets("Results")
Set s2 = Sheets("Rapor")
son = s1.Cells(Rows.Count, "A").End(3).Row
s1.Range("A2:A" & son).Copy s2.[A2]
s1.Range("B2:B" & son).Copy s2.[B2]
s1.Range("L2:L" & son).Copy s2.[C2]
Application.CutCopyMode = False
s2.Range("C2:C" & son).TextToColumns Destination:=Range("C2"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
    :="_", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), _
    TrailingMinusNumbers:=True
s2.Range("C2:C" & son).Delete Shift:=xlToLeft
For i = 2 To son
    sut = s2.Cells(i, Columns.Count).End(xlToLeft).Column
    isim = Empty
    For j = 4 To sut
        isim = isim & " " & s2.Cells(i, j)
    Next
    s2.Cells(i, "C") = s2.Cells(i, "C") & isim
    s2.Range(Cells(i, 4), Cells(i, sut)).ClearContents
Next
End Sub