Mesafeyi bulup yazsın

Katılım
24 Şubat 2009
Mesajlar
1,077
Excel Vers. ve Dili
2016
Altın Üyelik Bitiş Tarihi
01-03-2023
Merhaba arkadaşlar, sürekli görev yolluğunda MESAFE diye sayfam var, Adıyaman İlinin C8 hücresine yazmış olduğum, ilin mesafesini buradan bulup K8 Hücresine yazmasını istiyorum. Saygılarımla.
 

Ekli dosyalar

Ömer BARAN

Uzman
Katılım
8 Mart 2011
Mesajlar
12,997
Excel Vers. ve Dili
Office 2013 ( 32 bit ) TÜRKÇE
Altın Üyelik Bitiş Tarihi
(18.03.2020) - Uzman olduğu için tarih geçersiz oldu.

Ömer BARAN

Uzman
Katılım
8 Mart 2011
Mesajlar
12,997
Excel Vers. ve Dili
Office 2013 ( 32 bit ) TÜRKÇE
Altın Üyelik Bitiş Tarihi
(18.03.2020) - Uzman olduğu için tarih geçersiz oldu.
Kolay gelsin.
 
Katılım
6 Mart 2005
Mesajlar
6,233
Excel Vers. ve Dili
Excel Vers. ve Dili:
Office 2016 TR 64 Bit
Altın Üyelik Bitiş Tarihi
22/12/2022
Alternatif olarak.
Kod:
=EĞERHATA(YATAYARA($C$8;MESAFE!$C$3:$CE$5;3;0);"")
 
Katılım
24 Şubat 2009
Mesajlar
1,077
Excel Vers. ve Dili
2016
Altın Üyelik Bitiş Tarihi
01-03-2023
Sayın çıtır teşekkür ederim alternatif olarak birde makro yazabilir misin?
 
Katılım
6 Mart 2005
Mesajlar
6,233
Excel Vers. ve Dili
Excel Vers. ve Dili:
Office 2016 TR 64 Bit
Altın Üyelik Bitiş Tarihi
22/12/2022
Sayfa kodu olarak
Kod:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then
        Exit Sub
    End If
If Intersect(Target, [B8]) Is Nothing Then Exit Sub
Dim s1 As Worksheet
Set s1 = Sheets("MESAFE")
[K8] = WorksheetFunction.HLookup(Range("B8"), s1.Range("C3:CE5"), 3, 0)
End Sub
 
Katılım
6 Mart 2005
Mesajlar
6,233
Excel Vers. ve Dili
Excel Vers. ve Dili:
Office 2016 TR 64 Bit
Altın Üyelik Bitiş Tarihi
22/12/2022
Teşekkür ederim abim iyi geceler
Bir modüle kopyalayınız.Tüm sayfalara yazar.
Kod:
Sub ara()
Dim i As Integer
Dim s1 As Worksheet
Set s1 = Sheets("MESAFE")
For i = 1 To Worksheets.Count
sayfaadı = Worksheets(i).Name
If sayfaadı = "MESAFE" Then GoTo 10
If Sheets(i).Range("B8") = "" Then
Sheets(i).Range("K8") = ""
End If
say = WorksheetFunction.CountIf(s1.Range("c3:CE3"), Sheets(i).Range("B8"))
If say > 0 Then
Sheets(i).Range("K8") = WorksheetFunction.HLookup(Sheets(i).Range("B8"), s1.Range("C3:CE5"), 3, 0)
End If
If say = 0 Then
Sheets(i).Range("K8") = ""
End If
10:
Next i
End Sub
Dönüş yaptığınız için teşekkür ederim.İyi geçeler.
 
Katılım
24 Şubat 2009
Mesajlar
1,077
Excel Vers. ve Dili
2016
Altın Üyelik Bitiş Tarihi
01-03-2023
Merhaba sayın Çıtır, iyi geceler yazmış olduğunuz kodda birde I8 e veri getirmesini istiyorum, bu kodu düzenleye bilir misiniz? Teşekkürler
I8 de ücretler yer alacak, bunlarda CF sütununda..
 

Ekli dosyalar

Katılım
24 Şubat 2009
Mesajlar
1,077
Excel Vers. ve Dili
2016
Altın Üyelik Bitiş Tarihi
01-03-2023
iyi geceler arkadaşlar; 10 nolu mesajdaki dosyada dosyada K8 kilometreler geliyor, birde I8 e ücretlerin gelmesini istiyorum, koda nasıl bir değişiklik yapılabilir. Teşekkür ederim.
 

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,073
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
I8 formülü:

=EĞER(C8="";"";DÜŞEYARA(C8;MESAFE!$B$4:$CF$84;83;0))

#7 nolu mesajdaki sayfa kodu:

PHP:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then
        Exit Sub
    End If
If Intersect(Target, [C8:C17]) Is Nothing Then Exit Sub
Dim s1 As Worksheet
Set s1 = Sheets("MESAFE")
Target.Offset(0, 6) = WorksheetFunction.HLookup(Target, s1.Range("C3:CE5"), 3, 0)
End Sub
 

baydeniro

Altın Üye
Katılım
26 Ocak 2007
Mesajlar
4,625
Excel Vers. ve Dili
Ofis 2016
Altın Üyelik Bitiş Tarihi
20-02-2025
I8 formülü:

=EĞER(C8="";"";DÜŞEYARA(C8;MESAFE!$B$4:$CF$84;83;0))

#7 nolu mesajdaki sayfa kodu:

PHP:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then
        Exit Sub
    End If
If Intersect(Target, [C8:C17]) Is Nothing Then Exit Sub
Dim s1 As Worksheet
Set s1 = Sheets("MESAFE")
Target.Offset(0, 6) = WorksheetFunction.HLookup(Target, s1.Range("C3:CE5"), 3, 0)
End Sub
Tebrikler üstad, harika bir kod olmuş.
 
Katılım
24 Şubat 2009
Mesajlar
1,077
Excel Vers. ve Dili
2016
Altın Üyelik Bitiş Tarihi
01-03-2023
YUSUF abi bu yazdığın formül var ya=EĞER(C8="";"";DÜŞEYARA(C8;MESAFE!$B$4:$CF$84;83;0)) bunu koda ekleye bilir miyiz. Yani C8 Gideceği yeri yazınca kod ile ile hem I8 deki ücret, hemde K8 deki km gelecek. Yani formül olmadan sayfa koduna
 

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,073
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Bunu mu kastediyorsunuz?

Kod:
Private Sub Worksheet_Change(ByVal Target As Range)
If Selection.Count > 1 Then Exit Sub
    
If Intersect(Target, [C8:C17, A8:A17]) Is Nothing Then Exit Sub
Set s1 = Sheets("MESAFE")
a = Target.Row
son = s1.Cells(Rows.Count, "B").End(3).Row

If Cells(a, "A") <> "" And Cells(a, "C") <> "" Then
    If WorksheetFunction.CountIf(s1.Range("B1:B" & son), Cells(a, "A")) > 0 And _
        WorksheetFunction.CountIf(s1.Range("B1:B" & son), Cells(a, "C")) > 0 Then
            sat = WorksheetFunction.Match(Cells(a, "C"), s1.Range("B1:B" & son), 0)
            Cells(a, "I") = s1.Cells(sat, "CF")
            Cells(a, "K") = s1.Cells(sat, "D")
    ElseIf WorksheetFunction.CountIf(s1.Range("B1:B" & son), Cells(a, "A")) = 0 Then
        MsgBox "Çıkış yerini doğru yazınız!", vbCritical
        Exit Sub
    ElseIf WorksheetFunction.CountIf(s1.Range("B1:B" & son), Cells(a, "C")) = 0 Then
        MsgBox "Çıkış yerini doğru yazınız!", vbCritical
        Exit Sub
    End If
End If

End Sub
Ekleme: Kodda düzeltme yapıldı.
 
Son düzenleme:
Katılım
24 Şubat 2009
Mesajlar
1,077
Excel Vers. ve Dili
2016
Altın Üyelik Bitiş Tarihi
01-03-2023
Merhaba abim, eline sağlık benim için uğraştın, verilerde ücretler doğru geliyor, KM ler yanlış geliyor tabloyu bize göre düzenledim, İlçemize en alta aldım, bu durumda ücretler doğru geliyor, KM ler yanlış gelmesi gerekenleri yanda açıkladım, birde abi bunu modül 2'ye ekleyecek şekilde yazar mısın? Sana zahmet verdim ama dua ile kal.
 

Ekli dosyalar

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,073
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Dünkü kodlar dünkü dosyanıza göreydi ve dünkü dosyanızda doğru sonuçlar veriyordu. Siz bugün başka dosyada işlem yapıyorsunuz, dosya düzenini değiştirmiş, Gölbaşı'ya göre uygulanmasını istemişsiniz. Bu durumda makroda da değişiklikler yapılması gerekiyor. Her zaman örnek dosyanızla asıl dosyanız aynı yapıda olsun ve her zaman asıl sormak istediğinizi sorun lütfen.

Sayfa kodunu aşağıdakiyle değiştirip deneyin:

PHP:
Private Sub Worksheet_Change(ByVal Target As Range)
If Selection.Count > 1 Then Exit Sub
    
If Intersect(Target, [C8:C17, A8:A17]) Is Nothing Then Exit Sub
Set s1 = Sheets("MESAFE")
a = Target.Row
sonsat = s1.Cells(Rows.Count, "B").End(3).Row
sonsut = s1.Cells(3, Columns.Count).End(xlToLeft).Column

If Cells(a, "A") <> "" And Cells(a, "C") <> "" Then
    If WorksheetFunction.CountIf(s1.Range("B1:B" & sonsat), Cells(a, "A")) > 0 And _
        WorksheetFunction.CountIf(s1.Range(s1.Cells(3, "A"), s1.Cells(3, sonsut)), Cells(a, "C")) > 0 Then
            sat = WorksheetFunction.Match(Cells(a, "A"), s1.Range("B1:B" & sonsat), 0)
            satTL = WorksheetFunction.Match(Cells(a, "C"), s1.Range("B1:B" & sonsat), 0)
            sut = WorksheetFunction.Match(Cells(a, "C"), s1.Range(s1.Cells(3, "A"), s1.Cells(3, sonsut)), 0)
            Cells(a, "I") = s1.Cells(satTL, "CF")
            Cells(a, "K") = s1.Cells(sat, sut)
    ElseIf WorksheetFunction.CountIf(s1.Range("B1:B" & sonsat), Cells(a, "A")) = 0 Then
        MsgBox "Çıkış yerini doğru yazınız!", vbCritical
        Cells(a, "I").ClearContents
        Cells(a, "K").ClearContents
        Exit Sub
    ElseIf WorksheetFunction.CountIf(s1.Range(s1.Cells(3, "A"), s1.Cells(3, sonsut)), Cells(a, "C")) = 0 Then
        MsgBox "Çıkış yerini doğru yazınız!", vbCritical
        Cells(a, "I").ClearContents
        Cells(a, "K").ClearContents
        Exit Sub
    End If
End If

End Sub
Modüle kopyalamaktan kastınız nedir, ne yapmak istiyorsunuz?
 
Üst