Şehirler arası km hesaplatma

sakoz · 14 Kasım 2008

Kritere göre Şehirler arası km hesaplatma

Herkese Merhabalar ,

Ekte gönderdiğim dosyada B sütununda Varış yeri bilgisi , E sütunundada
İzmir ile varış noktası arasındaki km bilgisi yer almaktadır.
Örn :
varış yeri km bilgisi
konya 592 - Buradaki km izmir-konya arası
malatya 1251 - Buradaki km izmir-malatya arası

Yapmak istedigimiz ise A sütununda pozisyon nosu var ve aynı pozisyon nosu birden fazla var.Bu pozisyonların arasında birer satır boşluk var...Aynı pozisyon nosundaki B sütunundaki varış yerine göre F sütununa işlem yaptırtmak istiyoruz..Bunu nasıl yapabiliriz...
İlgilenen herkese şimdiden teşekkür ederim...
Saygılar...

sakoz · 14 Kasım 2008

Güncel , yardımcı olabilirmisiniz...?

sakoz · 14 Kasım 2008

Güncel , yardımlarınızı bekliyoruz...

sakoz · 14 Kasım 2008

Güncel , konuyla ilgili yardımcı olabilirmisiniz...Lütfen...

obas73 · 14 Kasım 2008

sakoz' Alıntı:
Güncel , konuyla ilgili yardımcı olabilirmisiniz...Lütfen...

.............

sakoz · 14 Kasım 2008

Arkadaşlar , yardımcı olabilirmisiniz lütfen....Konu güncel....

hsayar · 14 Kasım 2008

ilgileniyorum.......

hsayar · 14 Kasım 2008

salim burada edremit-çanakkkale arası mesafeyi km tablosuna girmemişsin?

sakoz · 14 Kasım 2008

Evet haklısın Hüseyin onu altamışım - 118 km olacak...

hsayar · 14 Kasım 2008

dosya 18.mesaja göre güncellenmiştir.

ben 130 km diye öğrendim edremit-çanakkleyi bizim şoförden sen onu düzelt, diğerlerini ben 9999 olarak geçtim onları da düzeltirsin;

gecikme için kusura bakma kaçıncı fonksiyonu olanlarda da #yok deyince çare aramak zorunda kaldım.

bu arada ilk 2 kaydın mahalli birim adları yanlıştır... dikkat et.
mahllai birimler km tablosundaki gibi gir afyon gireceksen kmden adını değiştir.

http://www.excel.web.tr/attachment.php?attachmentid=51999&stc=1&d=1226673497

Kod:

Sub Mesafeleri_Yaz()
Application.ScreenUpdating = False
  Dim csfRpr As Worksheet: Set csfRpr = ThisWorkbook.Worksheets("Rapor")
  Dim csfKmT As Worksheet: Set csfKmT = ThisWorkbook.Worksheets("KM")
  Dim rngBul As Range, rngAra As Range
  
  With csfRpr
    .Range(.Cells(2, "F"), .Cells(2000, "F")).Clear
    Stop
    For Each rngAra In .Range("A2:E500").SpecialCells(xlCellTypeConstants, 23).Areas
      arasonsat = rngAra.Row + (rngAra.Count / 5) - 1
      For i = rngAra.Row + 1 To arasonsat
        il1 = .Cells(i, "f").Offset(-1, -4)
        il2 = .Cells(i, "f").Offset(0, -4)
          With csfKmT                                                                                         '||
            If .FilterMode = True Then .ShowAllData                                       '||
            Set rngBul = .Range("A1:CX1").Cells.Find(il1, LookIn:=xlValues, LookAt:=xlWhole)             '||
            If (Not rngBul Is Nothing) Then
              il1ind = rngBul.Column - 2
            Else
              MsgBox "Km Tablosuna " & il1 & " tanımlayınız "
              Exit Sub
            End If
            
            Set rngBul = .Range("A1:A200").Cells.Find(il2, LookIn:=xlValues, LookAt:=xlWhole)             '||
            If (Not rngBul Is Nothing) Then
              il2ind = rngBul.Row - 2
            Else
              MsgBox "Km Tablosuna " & il2 & " tanımlayınız "
              Exit Sub
            End If
            
            Set rngBul = .Range(.Cells(3, 3), .Cells(100, 100))
            
            mesafe = WorksheetFunction.Index(rngBul, il2ind, il1ind)
            If mesafe = "" Or mesafe = 0 Or mesafe = 9999 Then
              msj = il1 & " - " & il2 & " arası mesafe < " & mesafe & " > km gözükmektedir."
              msj = msj & vbNewLine & "Lütfen kontrol ediniz."
              MsgBox msj
            End If
          End With
        .Cells(i, "f").Value = mesafe
      Next i
    Next rngAra
  End With
  Set rngAra = Nothing
  Set rngBul = Nothing
  Set csfKmT = Nothing
  Set csfRpr = Nothing
Application.ScreenUpdating = True
End Sub

istersen aşağıdaki prosodürüde değiştir.
çünkü boşluklarda sana hata gönderir.
Ekleme: aşağıdaki gibi kullanırsan satır açılır açılmaz km değerleride alınır.

Kod:

Sub Poz_No_Degistiginde_Satir_Ac()
    Dim i As Integer
    Dim x As Integer
    Dim sKon As String
    Dim rng As Range
    
    On Error GoTo Hata_Yakala
    
    For i = 2 To Cells(65536, 1).End(xlUp).Row
      If Cells(i, 2) <> "" Then Cells(i, 2) = Trim(Cells(i, 2)) 'Boşlukları Al
        If i = 2 Then
            sKon = Cells(i, 1)
        Else
            If Cells(i, 1) <> sKon Then
                sKon = Cells(i, 1)
                x = x + 1
                If x = 1 Then
                    Set rng = Cells(i, 1)
                Else
                    Set rng = Application.Union(rng, Cells(i, 1))
                End If
            End If
        End If
    Next i
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    rng.EntireRow.Insert
     Call Mesafeleri_Yaz

Hata_Yakala:
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
    Set rng = Nothing
End Sub

sakoz · 14 Kasım 2008

Aynı anda mesaj yazdık galiba....Rica ederim Hüseyin gecikme me demek ...İlgini ve emegini harcaman icin esas ben sana çok teşekkür ederim...Yalnız makroyu çalıştırınca arasonsat kısmında durdu..Compile error : Cant find project or library hatası verdi...Acaba Tools'dan eklemem gereken bir library mi var ?

hsayar · 14 Kasım 2008

sakoz' Alıntı:
Aynı anda mesaj yazdık galiba....Rica ederim Hüseyin gecikme me demek ...İlgini ve emegini harcaman icin esas ben sana çok teşekkür ederim...Yalnız makroyu çalıştırınca arasonsat kısmında durdu..Compile error : Cant find project or library hatası verdi...Acaba Tools'dan eklemem gereken bir library mi var ?

örnek dosyadada veriyormu...
ben 2007 kullanıyorum ama hata olacağını sanmıyorum.

sakoz · 14 Kasım 2008

Bende 2003 var..ve hata veriyor Hüseyin...Galiba benim eklemem gereken bir library falan var ondan veriyor...Senin gönderdiğin dosyadada denedim orada da aynı hatayı veriyor.

hsayar · 14 Kasım 2008

http://www.excel.web.tr/showthread.php?t=58489
ozaman buradaki sorunun cevabını bekleyeceğiz....
aralıktaki sonsatrı excel 2003 ile tespit ettiğimiz anda işlme tamamdır.
ben bunu;
alandaki hücresayısı = kolon sayısı * hücre sayısı ile bulunduğu için kolon sayısını tersten gidip hesapladım.
arasonsat = rngAra.Row + (rngAra.Count / 5) - 1
alternatif bir yöntem hatırlar veya bulursak işimiz çözülür.

sakoz · 14 Kasım 2008

Tamam Hüseyin bunun cevabını bekleyelim...Bu arada ben foruma koydugum dosyayı tekrar indirip onun üzerine makroyu ekledim....Sayfa2 nin adını rapor yaptım..Ondan sonra makroyu çalıştırdım...Burada da stop kısmında makro durdu...bu durum bahsettiğin konu ile ilgilimi acaba ?

hsayar · 14 Kasım 2008

Aşağıdaki şekilde görüldüğü gibi benim eklediğim yere Stop satırı ekle ve F5 e bas locals penceresinin ekran görüntüsünüde gönder.

değerli hocalarım özellikle Excel 2007 ve altında yukarıdaki resimde kırmızı ile çizilmiş olan 1 to 2 değerindeki 2 nasıl tespit edilir.

hsayar · 14 Kasım 2008

...........................................
mükerrer gitmiş.

hsayar · 14 Kasım 2008

sakoz' Alıntı:
1)Tamam Hüseyin bunun cevabını bekleyelim...
2)Bu arada ben foruma koydugum dosyayı tekrar indirip onun üzerine makroyu ekledim....
3)Sayfa2 nin adını rapor yaptım..
4)Ondan sonra makroyu çalıştırdım...Burada da stop kısmında makro durdu...bu durum bahsettiğin konu ile ilgilimi acaba ?

1) Cevabı beklemeye gerek kalmadı. Aralıklarında iki boyutlu dizi olduğu aklıma geldi.... Kodları aşağıdaki gibi değiştirerek dene;
2) İlk mesajdaki dosyanın km tablsounu ben ayarladım.
bu çalışma kitabı ve kendi çalıştığın kitap açıkken, senin açlışma kitabındaki KM sayfasını silip, benim eklediğim çalışma sayfasını sağ tkıklayıp taşı veya kopyaladan kendi çalışma kitabına kopyala.
3) evet rapor olacak
4) Stop olması kontrol amaçlı bir şey ' ile kapatabilirsin. ancak 16. mesajımdaki resme göre ayarlayıp bir ekran alıntısı yapıp bir gönder. 2003 te neden o hali çalışmadı merak ettim.

Kod:

Sub Mesafeleri_Yaz()
Application.ScreenUpdating = False
  Dim csfRpr As Worksheet: Set csfRpr = ThisWorkbook.Worksheets("Rapor")
  Dim csfKmT As Worksheet: Set csfKmT = ThisWorkbook.Worksheets("KM")
  Dim rngBul As Range, rngAra As Range
  
  With csfRpr
    .Range(.Cells(2, "F"), .Cells(2000, "F")).Clear
    For Each rngAra In .Range("A2:E500").SpecialCells(xlCellTypeConstants, 23).Areas
      'MsgBox UBound(rngAra.Value, 1) & " * " & UBound(rngAra.Value, 2)
      arasonsat = rngAra.Row + [B][COLOR=DarkGreen]UBound(rngAra.Value, 1)[/COLOR][/B] - 1
      For i = rngAra.Row + 1 To arasonsat
        il1 = .Cells(i, "f").Offset(-1, -4)
        il2 = .Cells(i, "f").Offset(0, -4)
          With csfKmT                                                                                         '||
            If .FilterMode = True Then .ShowAllData                                       '||
            Set rngBul = .Range("A1:CX1").Cells.Find(il1, LookIn:=xlValues, LookAt:=xlWhole)             '||
            If (Not rngBul Is Nothing) Then
              il1ind = rngBul.Column - 2
            Else
              MsgBox "Km Tablosuna " & il1 & " tanımlayınız "
              Exit Sub
            End If
            
            Set rngBul = .Range("A1:A200").Cells.Find(il2, LookIn:=xlValues, LookAt:=xlWhole)             '||
            If (Not rngBul Is Nothing) Then
              il2ind = rngBul.Row - 2
            Else
              MsgBox "Km Tablosuna " & il2 & " tanımlayınız "
              Exit Sub
            End If
            
            Set rngBul = .Range(.Cells(3, 3), .Cells(100, 100))
            
            mesafe = WorksheetFunction.Index(rngBul, il2ind, il1ind)
            If mesafe = "" Or mesafe = 0 Or mesafe = 9999 Then
              msj = il1 & " - " & il2 & " arası mesafe < " & mesafe & " > km gözükmektedir."
              msj = msj & vbNewLine & "Lütfen kontrol ediniz."
              MsgBox msj
            End If
          End With
        .Cells(i, "f").Value = mesafe
      Next i
    Next rngAra
  End With
  Set rngAra = Nothing
  Set rngBul = Nothing
  Set csfKmT = Nothing
  Set csfRpr = Nothing
Application.ScreenUpdating = True
End Sub

10.mesajdaki dosya güncellendi.

hsayar · 14 Kasım 2008

2003 kullanıcıları kodlarda hata alıp almadıklarını belirtirlerse sevinirim.

hsayar · 15 Kasım 2008

bu şekil gözüme daha güzel geldi, paylaşmak istedim.
.xlthin leri 2003 kullanıları silebilirler.

Kod:

Sub Mesafeleri_Yaz()
Application.ScreenUpdating = False
  Dim csfRpr As Worksheet: Set csfRpr = ThisWorkbook.Worksheets("Rapor")
  Dim csfKmT As Worksheet: Set csfKmT = ThisWorkbook.Worksheets("KM")
  Dim rngBul As Range, rngAra As Range
  
  With csfRpr
    .Range(.Cells(2, "F"), .Cells(500, "F")).Clear
    Call KenarlikYok(.Range(.Cells(2, "A"), .Cells(500, "F")))
    For Each rngAra In .Range("A2:E500").SpecialCells(xlCellTypeConstants, 23).Areas
      'MsgBox UBound(rngAra.Value, 1) & " * " & UBound(rngAra.Value, 2)
      arasonsat = rngAra.Row + UBound(rngAra.Value, 1) - 1
      For i = rngAra.Row + 1 To arasonsat
        il1 = .Cells(i, "b").Offset(-1, 0)
        il2 = .Cells(i, "b").Offset(0, 0)
          With csfKmT                                                                                         '||
            If .FilterMode = True Then .ShowAllData
            Set rngBul = .Range(.Cells(1, 3), .Cells(1, 104)).Find(il1, LookIn:=xlValues, LookAt:=xlWhole)
            If (Not rngBul Is Nothing) Then
              il1ind = rngBul.Column - 2
            Else
              MsgBox "Km Tablosuna " & il1 & " tanımlayınız "
              Exit Sub
            End If
            
            Set rngBul = .Range(.Cells(3, 1), .Cells(104, 1)).Find(il2, LookIn:=xlValues, LookAt:=xlWhole)
            If (Not rngBul Is Nothing) Then
              il2ind = rngBul.Row - 2
            Else
              MsgBox "Km Tablosuna " & il2 & " tanımlayınız "
              Exit Sub
            End If
            
            Set rngBul = .Range(.Cells(3, 3), .Cells(100, 100))
            
            mesafe = WorksheetFunction.Index(rngBul, il2ind, il1ind)
            If mesafe = "" Or mesafe = 0 Or mesafe = 9999 Then
              msj = il1 & " - " & il2 & " arası mesafe < " & mesafe & " > km gözükmektedir."
              msj = msj & vbNewLine & "Lütfen kontrol ediniz."
              MsgBox msj
            End If
          End With
        .Cells(i, "f").Value = mesafe
        knrAdr = Replace(rngAra.Address(False, False), "E", "F")
        Call KenarlikCiz_DisCift_Ic_Ince(.Range(knrAdr))
      Next i
    Next rngAra
  End With
  Set rngAra = Nothing
  Set rngBul = Nothing
  Set csfKmT = Nothing
  Set csfRpr = Nothing
Application.ScreenUpdating = True
End Sub

Kod:

Sub KenarlikYok(Aralik As Range)
'msrtkp için
 With Aralik
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    .Borders(xlEdgeLeft).LineStyle = xlNone
    .Borders(xlEdgeTop).LineStyle = xlNone
    .Borders(xlEdgeBottom).LineStyle = xlNone
    .Borders(xlEdgeRight).LineStyle = xlNone
    .Borders(xlInsideVertical).LineStyle = xlNone
    .Borders(xlInsideHorizontal).LineStyle = xlNone
    End With
End Sub

Kod:

Sub KenarlikCiz_DisCift_Ic_Ince(Aralik As Range)
On Error GoTo hatalıişlem
   With Aralik
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        With .Borders(xlEdgeLeft)
            .LineStyle = xlDouble
            .ColorIndex = xlAutomatic
            .Weight = xlThick
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlDouble
            .ColorIndex = xlAutomatic
            .Weight = xlThick
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlDouble
            .ColorIndex = xlAutomatic
            .Weight = xlThick
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlDouble
            .ColorIndex = xlAutomatic
            .Weight = xlThick
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .Weight = xlThin
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .Weight = xlThin
        End With
    End With
Exit Sub
hatalıişlem:
MsgBox "Bir hata oluştu.: " & Err.Number & vbNewLine & "Açıklama: " & Err.Description
End Sub

Şehirler arası km hesaplatma

sakoz

Ekli dosyalar

sakoz

sakoz

sakoz

obas73

sakoz

hsayar

hsayar

sakoz

hsayar

Ekli dosyalar

sakoz

hsayar

sakoz

hsayar

sakoz

hsayar

hsayar

hsayar

hsayar

hsayar