• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Mesafeyi bulup yazsın

H

Hacı Bayram ÖZKAN

Katılım
24 Şubat 2009
Mesajlar
1,077
Excel Vers. ve Dili
2016
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

Alternatif olarak.
Kod: 
=EĞERHATA(YATAYARA($C$8;MESAFE!$C$3:$CE$5;3;0);"")
 
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
 
tarzanhaci' Alıntı:
Teşekkür ederim abim iyi geceler
Genişletmek için tıkla ...
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.
 
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

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.
 
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
 
YUSUF44' Alıntı:
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
Genişletmek için tıkla ...
Tebrikler üstad, harika bir kod olmuş.
 
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
 
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:
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

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?
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst