DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Option Explicit
Sub Create_Hyperlink()
Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object
Dim Son As Long, Veri As Variant, X As Long, Zaman As Double
Zaman = Timer
Application.ScreenUpdating = False
Set S1 = Sheets("Genel")
Set S2 = Sheets("Hukuk")
Set Dizi = CreateObject("Scripting.Dictionary")
S1.Range("G2:G" & S1.Rows.Count).ClearContents
Son = S2.Cells(S2.Rows.Count, 8).End(3).Row
Veri = S2.Range("H2:J" & Son).Value
For X = LBound(Veri) To UBound(Veri)
If Not Dizi.Exists(Veri(X, 1) & Veri(X, 2) & Veri(X, 3)) Then
Dizi.Add Veri(X, 1) & Veri(X, 2) & Veri(X, 3), X + 1
Else
Dizi.Item(Veri(X, 1) & Veri(X, 2) & Veri(X, 3)) = X + 1
End If
Next
Son = S1.Cells(S1.Rows.Count, 4).End(3).Row
Veri = S1.Range("D2:F" & Son).Value
For X = LBound(Veri) To UBound(Veri)
If Dizi.Exists(Veri(X, 1) & Veri(X, 2) & Veri(X, 3)) Then
S1.Hyperlinks.Add Anchor:=S1.Range("G" & X + 1), Address:="", _
SubAddress:="'" & S2.Name & "'!J" & Dizi.Item(Veri(X, 1) & Veri(X, 2) & Veri(X, 3)), TextToDisplay:="Var"
Else
S1.Hyperlinks.Add Anchor:=S1.Range("G" & X + 1), Address:="", _
SubAddress:="", TextToDisplay:="Yok"
End If
Next
Set S1 = Nothing
Set S2 = Nothing
Set Dizi = Nothing
Application.ScreenUpdating = True
MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Set S = Sheets("Hukuk")
On Error Resume Next
satır = S.Range("J:J").Find(What:=Target, LookAt:=xlWhole).Row
If Not IsEmpty(satır) = True And Target.Value <> "" Then
If S.Range("J" & satır).Value = Target.Value And S.Range("I" & satır).Value = Target.Offset(0, -1).Value And S.Range("H" & satır).Value = Target.Offset(0, -2).Value Then
S.Activate
S.Range("H" & satır & ":J" & satır).Select
End If
End If
End Sub
Alibey çok teşekkür ederim. Ancak dediğiniz gibi formülü kod bölümüne yapıştırdım makro adı istedi yazdım ancak yapamadım çalıştıramadım . Yinede emek verdiğiniz için çok teşekkür ederim.Alternatif
Köprü yerine Genel sayfasında "No" ların (F Sütunuda) hücre üzerinde Çift tıklayınca Hukuk sayfasında ilgili hücreleri seçen kod aşağıda, bu kodları Genel sayfasının Kod modülüne yapıştırın.
Kod:Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Set S = Sheets("Hukuk") On Error Resume Next satır = S.Range("J:J").Find(What:=Target, LookAt:=xlWhole).Row If Not IsEmpty(satır) = True And Target.Value <> "" Then If S.Range("J" & satır).Value = Target.Value And S.Range("I" & satır).Value = Target.Offset(0, -1).Value And S.Range("H" & satır).Value = Target.Offset(0, -2).Value Then S.Activate S.Range("H" & satır & ":J" & satır).Select End If End If End Sub
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim veri As Range, S1 As Worksheet, S2 As Worksheet
Dim S3 As Worksheet, Dizi As Object, Tablo As Variant
Dim X As Long, WF As WorksheetFunction, Son As Long
If Intersect(Target, Range("D2:K" & Rows.Count)) Is Nothing Then Exit Sub
Set S1 = Sheets("Dosyalar")
Set S2 = Sheets("Hukuk")
Set S3 = Sheets("Ceza")
Set WF = WorksheetFunction
Set Dizi = CreateObject("Scripting.Dictionary")
For Each veri In Target.Cells
Select Case veri.Column
Case 4 To 6
If WorksheetFunction.CountA(Range(Cells(veri.Row, "D"), Cells(veri.Row, "F"))) = 3 Then
Son = S2.Cells(S2.Rows.Count, 8).End(3).Row
Tablo = S2.Range("E2:G" & Son).Value
For X = LBound(Tablo) To UBound(Tablo)
If Not Dizi.Exists(Tablo(X, 1) & Tablo(X, 2) & Tablo(X, 3)) Then
Dizi.Add Tablo(X, 1) & Tablo(X, 2) & Tablo(X, 3), X + 1
Else
Dizi.Item(Tablo(X, 1) & Tablo(X, 2) & Tablo(X, 3)) = X + 1
End If
Next
If Dizi.Exists(Cells(veri.Row, "D") & Cells(veri.Row, "E") & Cells(veri.Row, "F")) Then
S1.Hyperlinks.Add Anchor:=S1.Cells(veri.Row, "S"), Address:="", _
SubAddress:="'" & S2.Name & "'!G" & Dizi.Item(Cells(veri.Row, "D") & Cells(veri.Row, "E") & Cells(veri.Row, "F")), TextToDisplay:="Var"
Else
S1.Hyperlinks.Add Anchor:=S1.Cells(veri.Row, "S"), Address:="", _
SubAddress:="", TextToDisplay:="Yok"
End If
Son = S3.Cells(S3.Rows.Count, 8).End(3).Row
Tablo = S3.Range("E2:G" & Son).Value
For X = LBound(Tablo) To UBound(Tablo)
If Not Dizi.Exists(Tablo(X, 1) & Tablo(X, 2) & Tablo(X, 3)) Then
Dizi.Add Tablo(X, 1) & Tablo(X, 2) & Tablo(X, 3), X + 1
Else
Dizi.Item(Tablo(X, 1) & Tablo(X, 2) & Tablo(X, 3)) = X + 1
End If
Next
If Dizi.Exists(Cells(veri.Row, "D") & Cells(veri.Row, "E") & Cells(veri.Row, "F")) Then
S1.Hyperlinks.Add Anchor:=S1.Cells(veri.Row, "T"), Address:="", _
SubAddress:="'" & S3.Name & "'!G" & Dizi.Item(Cells(veri.Row, "D") & Cells(veri.Row, "E") & Cells(veri.Row, "F")), TextToDisplay:="Var"
Else
S1.Hyperlinks.Add Anchor:=S1.Cells(veri.Row, "T"), Address:="", _
SubAddress:="", TextToDisplay:="Yok"
End If
End If
Case 8
If Cells(veri.Row, 8) = Empty Then
Cells(veri.Row, 12) = Empty
Cells(veri.Row, 13) = Empty
ElseIf WF.IsNumber(Cells(veri.Row, 8)) Then
Cells(veri.Row, 12) = Cells(veri.Row, 8) + 160
Cells(veri.Row, 13) = Cells(veri.Row, 12) - Date
Else
Cells(veri.Row, 12) = Cells(veri.Row, 8)
Cells(veri.Row, 13) = ""
End If
Case 9
If Cells(veri.Row, 9) = Empty Then
Cells(veri.Row, 14) = Empty
Cells(veri.Row, 15) = Empty
ElseIf WF.IsNumber(Cells(veri.Row, 9)) Then
Cells(veri.Row, 14) = Cells(veri.Row, 9) + 335
Cells(veri.Row, 15) = Cells(veri.Row, 14) - Date
Else
Cells(veri.Row, 14) = Cells(veri.Row, 9)
Cells(veri.Row, 15) = Cells(veri.Row, 9)
End If
Case 10
If Cells(veri.Row, 10) = Empty Then
Cells(veri.Row, 16) = Empty
ElseIf WF.IsNumber(Cells(veri.Row, 10)) Then
Cells(veri.Row, 16) = Cells(veri.Row, 10) + 45
ElseIf Cells(veri.Row, 10) = "" Then
Cells(veri.Row, 16) = ""
Else
Cells(veri.Row, 16) = Cells(veri.Row, 10)
End If
Case 11
If Cells(veri.Row, 10) = Empty Then
Cells(veri.Row, 17) = Empty
Cells(veri.Row, 18) = Empty
ElseIf WF.IsNumber(Cells(veri.Row, 11)) Then
Cells(veri.Row, 17) = Cells(veri.Row, 11) + 335
Cells(veri.Row, 18) = Cells(veri.Row, 17) - Date
Else
Cells(veri.Row, 17) = Cells(veri.Row, 11)
Cells(veri.Row, 18) = Cells(veri.Row, 11)
End If
End Select
Next
Set S1 = Nothing
Set S2 = Nothing
Set S3 = Nothing
Set WF = Nothing
Set Dizi = Nothing
End Sub
Ayrıca verileri excele yapıştırınca hata verdi: Cells(Veri.Row, 18) = Cells(Veri.Row, 17) - DateKorhan bey ,
Öncelikle hemen dönüş yapamadığım için kusura bakmayın evdeki pc bozuldu. Teşekkürlerimi sunamadım. ellerinize sağlık.Biraz aksaklık var benden de kaynaklı olabilir bilmiyorum
Tüm SATIRLARDA aşağıdaki aynı kaynaklı sorun var .
mesala
Örnek : H sutununa bügün tarihi 15.06.2020 girildiğinde , (L) sutununda 160 gün sonrası 22.11.2020 vermesi lazım.
M sutununda ise her iki tarih arasındaki kalan gün sayısını vermesi gerekir yani 160 gün.
L SUTUNU 160 GÜN SONRASINI VERMİYOR AYNI TARİH YAZIYOR
teşekkürlerimi sunuyorum