Hücre ve font rengine göre düşeyara ile veri çekme

[asi_kral]

Merhaba;
Peki bu tarihe göre değişmesini istediğim verileri başka nasıl halledebiliriz, farklı bir yöntemi var mıdır?

Örnek dosya bir nöbet listesidir ve günlük olarak 4' lü ekipler yer değiştirecek, amaç bu..

Merhaba
Şöyle bir şey yapılabilir. Sıralama sayfasındaki K1 - - Z1 ler kullanılır. Siz sadece tarih değiştirirsiniz gerisini o dizer. Bana mantıklı gelen bu şu an. Belki farklı düşünceleri olan vardır.

 

[pasha22]

Dediğiniz gibi ben "sıralama" sayfasında sadece K1 - Z1 kodlarını kullandım.
"Şablon" sayfasında tarih değişince kodlar da bölgelere göre değişerek gelmesi lazım ama bütün sorun da burada zaten..

 

[asi_kral]

Dediğiniz gibi ben "sıralama" sayfasında sadece K1 - Z1 kodlarını kullandım.
"Şablon" sayfasında tarih değişince kodlar da bölgelere göre değişerek gelmesi lazım ama bütün sorun da burada zaten..

Ne istediğinizi anlayamadım. Tam olarak ne yapmam gerek nasıl çözüm üreteyim sizin için.

 

[pasha22]

Merhaba
Şöyle bir şey yapılabilir. Sıralama sayfasındaki K1 - - Z1 ler kullanılır. Siz sadece tarih değiştirirsiniz gerisini o dizer. Bana mantıklı gelen bu şu an. Belki farklı düşünceleri olan vardır.

Bu dediğinizi nasıl yapacağım?

 

[asi_kral]

Bu dediğinizi nasıl yapacağım?

Merhaba
Şablon sayfasının kod bölümündeki kodları silin.

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim S1 As Worksheet, STR As Long, STN As Long, S2 As Worksheet
Dim STR1 As Range, DRS As Range, SBT As Variant
Application.ScreenUpdating = False
Application.EnableEvents = False
If Intersect(Target, Range("N1")) Is Nothing Then _
Application.EnableEvents = True: Application.ScreenUpdating = True: _
Exit Sub
Range("B7:P10").Clear: Range("B13:P16").Clear
Range("B19:P22").Clear: Range("B25:P28").Clear
Range("B31:P34").Clear: Range("B37:P40").Clear
Range("B43:P47").Clear: Range("B50:P54").Clear
SBT = ActiveCell.Address
Set S1 = Sheets("SIRALAMA"): Set S2 = Sheets("TÜM GRUP KODLARI")
With WorksheetFunction
STR = .Match(Range("N1"), S1.Range("A:A"), 0)
End With
For STN = 2 To S1.Cells(STR, Columns.Count).End(xlToLeft).Column Step 4
If S1.Cells(STR, STN) <> Empty Then
Set DRS = Range("B:P").Find(S1.Cells(1, STN), , , xlWhole)
Set STR1 = S2.Range("A:M").Find(S1.Cells(STR, STN), , , xlWhole)
S2.Range(S2.Cells(STR1.Row, STR1.Column + 1).Address & ":" & S2.Cells(STR1.Row + 3, STR1.Column + 3).Address).Copy
Range(Cells(DRS.Row + 1, DRS.Column).Address).PasteSpecial
Application.CutCopyMode = False
End If
Next
Range(SBT).Select
Application.EnableEvents = True: Application.ScreenUpdating = True
End Sub

Bu kodu oraya kopyalayın ve deneyin.
Tarih değiştikçe veriler değişecektir.

 

[pasha22]

Bu kodu oraya kopyalayın ve deneyin.
Tarih değiştikçe veriler değişecektir.

Merhaba asi_kral;
bu kodlar sayesinde istemiş olduğum verileri elde ettim, yardımlarınız ve emekleriniz için size çok teşekkür ederim.
Saygılarımla.

 

[asi_kral]

Merhaba asi_kral;
bu kodlar sayesinde istemiş olduğum verileri elde ettim, yardımlarınız ve emekleriniz için size çok teşekkür ederim.
Saygılarımla.

Kolay Gelsin.