Renksiz hücredeki veriyi alma

[morfiss]

Merhabalar,

Elimde 8-9 alt sekmeli bir çizelgem var. Çizelgede ürünler tamir edildiğinde koşullu biçimlendirmeyle satırlar yeşile boyanıyor. Amacım alt sekmelerdeki çizelgelerde yeşil boyalı olmayan ürünleri(tamir edilmeyen ürünleri) formül vererek ayrı bir sekmede toparlamak. Yani alt sekmelerde bulunan renksiz tüm hücreleri diğer bir sekmeye alt alta ekleyebilir miyim? Amacım tamir edilmeyen tüm ürünleri tek yerde görebilmek.

 

[Korhan Ayhan]

Merhaba,

Çözüm için örnek dosya paylaşmalısınız. Dosyanızı paylaşım sitelerine yükleyip linkini paylaşabilirsiniz.

 

[morfiss]

Merhaba,

Çözüm için örnek dosya paylaşmalısınız. Dosyanızı paylaşım sitelerine yükleyip linkini paylaşabilirsiniz.

Üstat dosya linki aşağıdadır. İçine açıklama yazdım.

İndir TEST

Dosyayı indir TEST

dosya.co

 

[Korhan Ayhan]

Merhaba,

İşlemin formülle yapılması uğraştırıcı olacaktır. Aşağıdaki kod ile verileri hızlı ve pratik şekilde aktarabilirsiniz.

Option Explicit

Sub Aktar()
    Dim WS As Worksheet, Son As Long, S1 As Worksheet
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("ÖZET")
    S1.Range("A2:L" & S1.Rows.Count).Clear
    
    For Each WS In ThisWorkbook.Worksheets
        If WS.Name <> "ÖZET" Then
            WS.Range("A1:L" & WS.Rows.Count).AutoFilter 12, ""
            Son = WS.Cells(WS.Rows.Count, 1).End(3).Row
            If Son > 1 Then
                WS.Range("B2:L" & Son).Copy S1.Cells(S1.Rows.Count, 2).End(3)(2, 1)
            End If
            WS.Range("A1:L" & WS.Rows.Count).AutoFilter
        End If
    Next
    
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    If Son > 1 Then
        S1.Range("A2") = 1
        S1.Range("A2:A" & Son).DataSeries Rowcol:=xlColumns, Type:=xlLinear
        S1.Range("A:A").HorizontalAlignment = xlCenter
        S1.Range("A1:L" & Son).Borders.LineStyle = 1
    End If
    
    Application.ScreenUpdating = True
    
    MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
End Sub

 

[morfiss]

Merhaba,

İşlemin formülle yapılması uğraştırıcı olacaktır. Aşağıdaki kod ile verileri hızlı ve pratik şekilde aktarabilirsiniz.

Option Explicit

Sub Aktar()
    Dim WS As Worksheet, Son As Long, S1 As Worksheet
   
    Application.ScreenUpdating = False
   
    Set S1 = Sheets("ÖZET")
    S1.Range("A2:L" & S1.Rows.Count).Clear
   
    For Each WS In ThisWorkbook.Worksheets
        If WS.Name <> "ÖZET" Then
            WS.Range("A1:L" & WS.Rows.Count).AutoFilter 12, ""
            Son = WS.Cells(WS.Rows.Count, 1).End(3).Row
            If Son > 1 Then
                WS.Range("B2:L" & Son).Copy S1.Cells(S1.Rows.Count, 2).End(3)(2, 1)
            End If
            WS.Range("A1:L" & WS.Rows.Count).AutoFilter
        End If
    Next
   
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    If Son > 1 Then
        S1.Range("A2") = 1
        S1.Range("A2:A" & Son).DataSeries Rowcol:=xlColumns, Type:=xlLinear
        S1.Range("A:A").HorizontalAlignment = xlCenter
        S1.Range("A1:L" & Son).Borders.LineStyle = 1
    End If
   
    Application.ScreenUpdating = True
   
    MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
End Sub

Üstat öncelikle teşekkür ederim. Kodu uygulayınca verileri getirdi. Yeni veri girdiğimde makroyu çalıştırınca veya verileri makroyla getirirp tekrar makroyu çalıştırınca 400 hatası alıyorum. Bunun için yapabileceğim bişey var mıdır?

 

[Korhan Ayhan]

Merhaba,

Kod da 400 hatası verecek bir durum yok. Bilgisayarınızı kapatıp açtıktan sonra kodu tekrar deneyiniz.

 

[morfiss]

Merhaba,

Kod da 400 hatası verecek bir durum yok. Bilgisayarınızı kapatıp açtıktan sonra kodu tekrar deneyiniz.

Yeni ürün girdiğimde veriyi çektiremedim. Bilgisayarı kapatıp açtım yine de olmadı. Acaba veri aldığı alan sınırlı mı ? Eğer sınırlı alanı al diye seçiliyse onu nasıl artırabilirim?

 

[Korhan Ayhan]

Herhangi bir alan sınırlaması yoktur.