bağ yapıştır

[pylor]

arkadaşlar istediğim şey bağ yapıştır örneği gibi ama tam olarak öyle değil veri tabanı sayfamda örneğin A1 hücresine veriyi girdim ve enter tuşuna bastım yada yön tuşu ile hücreyi terk ettim istediğim şey ben hücreyi terk ettiğim anda hücrede herhangi bir veri var ise o verinin data sayfasında aynı hücreye yazılması yanı veri tabanı sayfasında A1 hücresine veri girip entere bastığımda o verinin data sayfasında A1 hücresine yazılması böyle bir şey yapılabilirmi acaba daha anlaşılır olması için ekte bir dosya gönderdim umarım yardımcı olur teşekkürler

 

[Ömer]

Merhaba,

Tablodaki ölçüt renk değilde sütun başlığı olsa daha doğru olmaz mı?

Renk de olabilir fakat sütun başlığına göre aktarım yaparsak bence daha mantıklı olacak. Bu durumu netleştirince kodu yazmaya başlarım.

Diğer bir konu ise satırların hiç bir önemi yok mu? Aktarım nasıl yapılacak. D10 a veri girince data sayfası C sütununda bunun yerine ne olacak ve devamı nasıl ilerleyecek.

.

 

[pylor]

sayım ömer ilginize teşekkür ederim sorumda anlatım ve ifade bozukluğu olduğu için kusuruma bakmayın şöyle söylim veri tabanı sayfasındaki sütün başlıkları ile data sayfasındaki sütun başlıkları birbirini tutmadığı için ben veri tabanı sayfasında hangi sütundan verinin alınıp data sayfasında hangi sütuna yazılacağını belirtmek için renkleri kullandım yani renklerin bir önemi yok anlaşılır olsun diye öyle yaptım size nasıl kolay gelecekse öyle yapabilirsiniz. ikinci belirsizlikte satırlar tabiki önemli örneğin ekteki dosyadada göreceğiniz üzere ben veri tabanı sayfasında C,D,E,F,K ve M sütunlarından verileri alıp data sayfasında aralarında boşluk olmadan A,B,C,D ve F sütunlarına yazmak istiyorum burada veriler hangi satırdan alındıysa data sayfasında aynı satıra yazılacak örneğin ben ilk yatan hasta için C,D,E,F sütunlarının 2. satırlarını doldurduktan sonra ameliyat olup olmayacakları belli olmadığı için K ve M sütunlarının 2. satırlarını boş bırakıp 2. hasta için aynı sütunların 3. satırlarına veri kaydı yapıyorum sonra ameliyat tarihleri belli olduğu zaman boş bıraktığım satırları doldurup kaydı tamamlıyorum yani burada veriler hangi sütunun hangi satırından alındıysa data sayfasında ilgili sütunun aynı satırına yazılacak sayın ömer biraz uzun oldu ama kusura bakmayın umarım yardımı olmuştur

 

[Ömer]

A2 hücresine yazarak yana ve alt hücrelere kopyalayınız.

=KAYDIR('VERİ TABANI'!$C$2;SATIR()-2;ELEMAN(SÜTUN();6;5;4;3;11;13)-3)

.

 

[pylor]

Sayın ömer bu işin bu kodla nasıl bu kadar verimli çalıştığını merak ediyor olmam bir yana zekanıza ve pratik çözümünüze hayran olmamak elde değil cevabınızdan dolayı çok teşekkür ederim işimi gördü fakat bu işi fonsiyon yerine kodlar ile yapma şansimız olurmu acaba

 

[Ömer]

Övgü dolu sözleriniz için teşekkür ederim.

Kod ile de olur tabiki.

Kodları butonlamı çalıştıracaksınız, veri girişi esnasında mı, data sayfası aktif olduğunda mı?

.

 

[pylor]

sayın ömer övgüyü hak etmeyen insanların boş amaçlar uğruna sanki hak edermişçesine övülmeleri çok zoruma gittiği için hak eden bir kimseyi övmekten gurur duyduğumu belirtmek isterim ben kodların veri girildikten sonra aktif olmasını tercih ederim sizin için bir sakıncası yoksa teşekkür ederim

 

[Ömer]

Veri Tabanı sayfası kod bölümüne kopyalayınız.

Private Sub Worksheet_Change(ByVal Target As Range)
 
    Dim Sd As Worksheet, deg As Byte
 
    If Intersect(Target, Range("C2:F65000,K2:K65000,M2:M65000")) _
                Is Nothing Then Exit Sub
    If Selection.Cells.Count > 1 Then Exit Sub
 
    Set Sd = Sheets("DATA")
 
    deg = WorksheetFunction.Choose(Target.Column, _
                    1, 1, 4, 3, 2, 1, 1, 1, 1, 1, 5, 1, 6)
 
    Sd.Cells(Target.Row, deg) = Target.Value
 
End Sub

.

 

[pylor]

sayın ömer aynı sayfanın kod bölümünde

Private Sub Worksheet_Change(ByVal Target As Range)
Dim deg As String, adres As String, formul As String
Dim formul_adres_1 As String, formul_adres_2 As String

If Intersect(Target, Range("f:f")) Is Nothing Then Exit Sub

On Error Resume Next
deg = UCase(Replace(Replace(Target.Value, "ı", "I"), "i", "İ"))
adres = "f" & Target.Row & ":g" & Target.Row
Range(adres).Interior.ColorIndex = xlNone
Target.Interior.ColorIndex = xlNone
Target.Offset(0, 1).ClearContents

formul_adres_1 = "c2:c" & Target.Row
formul_adres_2 = "f2:f" & Target.Row
formul = "=SUMPRODUCT((YEAR(" & formul_adres_1 & ")=YEAR(" & "c" & Target.Row & "))*(" & formul_adres_2 & "=" & Target.Address & "))"

If deg = "B" Then
Range(adres).Interior.Color = vbBlue
Target.Offset(0, 1) = Evaluate(formul)
ElseIf deg = "İ" Then
Range(adres).Interior.Color = vbRed
Target.Offset(0, 1) = Evaluate(formul)
ElseIf deg = "S" Then
Range(adres).Interior.Color = vbYellow
Target.Offset(0, 1) = Evaluate(formul)
ElseIf deg = "K" Then
Range(adres).Interior.ColorIndex = 53
Target.Offset(0, 1) = Evaluate(formul)
ElseIf deg = "C" Then
Range(adres).Interior.ColorIndex = 10
Target.Offset(0, 1) = Evaluate(formul)
ElseIf deg = "L" Then
Range(adres).Interior.ColorIndex = 20
Target.Offset(0, 1) = Evaluate(formul)
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

Dim Sd As Worksheet, deg As Byte

If Intersect(Target, Range("C2:F65000,K2:K65000,M2:M65000")) _
Is Nothing Then Exit Sub
If Selection.Cells.Count > 1 Then Exit Sub

Set Sd = Sheets("DATA")

deg = WorksheetFunction.Choose(Target.Column, _
1, 1, 4, 3, 2, 1, 1, 1, 1, 1, 5, 1, 6)

Sd.Cells(Target.Row, deg) = Target.Value

End Sub

şeklinde bir oluşum meydana geldi daha önceden bu bölümde bir kod daha vardı ben sizin kodunuzu bu kodun altına yerleştirdim ancak kodlar çalışmadı diğer kodda sizin kodda hata verdi tek tek kullandığım zaman bir sorun yok ama ikisini alt alta yerleştirince hata veriyor bu sorunu nasıl çözebilirim acaba

 

[Ömer]

aynı sayfanın kod bölümünde
........
şeklinde bir oluşum meydana geldi daha önceden bu bölümde bir kod daha vardı ben sizin kodunuzu bu kodun altına yerleştirdim ancak kodlar çalışmadı diğer kodda sizin kodda hata verdi tek tek kullandığım zaman bir sorun yok ama ikisini alt alta yerleştirince hata veriyor bu sorunu nasıl çözebilirim acaba

Bu tür detayları ilk mesajda belirtmenizi rica ederim.

Kodları aşağıdakilerle değiştiriniz.

Private Sub Worksheet_Change(ByVal Target As Range)
 
Dim deg As String, adres As String, formul As String
Dim formul_adres_1 As String, formul_adres_2 As String
[COLOR=red]Dim Sd As Worksheet, sut As Byte[/COLOR]
 
[COLOR=red]If Intersect(Target, Range("C:F,K:K,M:M")) Is Nothing Then Exit Sub[/COLOR]
[COLOR=red]If Selection.Cells.Count > 1 Then Exit Sub[/COLOR]
 
[COLOR=red]Set Sd = Sheets("DATA")[/COLOR]
[COLOR=red]sut = WorksheetFunction.Choose(Target.Column, _[/COLOR]
[COLOR=red]                   1, 1, 4, 3, 2, 1, 1, 1, 1, 1, 5, 1, 6)[/COLOR]
 
[COLOR=red]If Target.Column = 6 Then[/COLOR]
 
On Error Resume Next
deg = UCase(Replace(Replace(Target.Value, "ı", "I"), "i", "İ"))
adres = "f" & Target.Row & ":g" & Target.Row
Range(adres).Interior.ColorIndex = xlNone
Target.Interior.ColorIndex = xlNone
Target.Offset(0, 1).ClearContents
formul_adres_1 = "c2:c" & Target.Row
formul_adres_2 = "f2:f" & Target.Row
formul = "=SUMPRODUCT((YEAR(" & formul_adres_1 & ")=YEAR(" & "c" & Target.Row & "))*(" & formul_adres_2 & "=" & Target.Address & "))"
 
[COLOR=red]Sd.Cells(Target.Row, sut) = Target.Value[/COLOR]
 
If deg = "B" Then
Range(adres).Interior.Color = vbBlue
Target.Offset(0, 1) = Evaluate(formul)
ElseIf deg = "İ" Then
Range(adres).Interior.Color = vbRed
Target.Offset(0, 1) = Evaluate(formul)
ElseIf deg = "S" Then
Range(adres).Interior.Color = vbYellow
Target.Offset(0, 1) = Evaluate(formul)
ElseIf deg = "K" Then
Range(adres).Interior.ColorIndex = 53
Target.Offset(0, 1) = Evaluate(formul)
ElseIf deg = "C" Then
Range(adres).Interior.ColorIndex = 10
Target.Offset(0, 1) = Evaluate(formul)
ElseIf deg = "L" Then
Range(adres).Interior.ColorIndex = 20
Target.Offset(0, 1) = Evaluate(formul)
End If
[COLOR=red]Else[/COLOR]
[COLOR=red]Sd.Cells(Target.Row, sut) = Target.Value[/COLOR]
[COLOR=red]End If[/COLOR]
End Sub

.

 

[pylor]

Sayın ömer detayı atladığım için kusura bakmyın bu konuda özürleri kabul edin lütfen kod için teşekkürler işimi gördü iyi akşamlar