Rota Haritalama

tamer42 · 13 Nisan 2023

Merhaba,
Ekli dosya "Data" sayfasında verilen araç rotalarını;

"Harita" sayfasında içinde adres numaraları yazılmış olan hücrelere,
bir hücre merkezinden diğer hücre merkezine düz çizgi ile çizme işlemini makro kodu ile nasıl yapabiliriz?
Özetle ekteki dosya Harita sayfasında manuel olarak çizmiş olduğum çizgileri kod ile yaptırmak istiyorum

Teşekkürler,

iyi Çalışmalar.

veyselemre · 14 Nisan 2023

Kod:

Sub rota()
    Dim shp As Object, rota
    With Sheets("Harita")
        For Each shp In ActiveSheet.Shapes
            shp.Delete
        Next shp
    End With
    With Sheets("data")
        rota = Application.Index(.Range("B6:M6").Value, 0, 0)
        rotaCiz (rota)
        rota = Application.Index(.Range("B8:M8").Value, 0, 0)
        rotaCiz (rota)
    End With
End Sub

Sub rotaCiz(rota)
    Dim rng As Range, huc As Range, lf, tp, i, ilkNokta, sonNokta, aNok, bNok, shp, msg
    With Sheets("Harita")
        Set rng = .UsedRange
        With CreateObject("Scripting.Dictionary")
            For Each huc In rng
                If IsNumeric(huc.Value) Then
                    lf = huc.Left + (huc.Width / 2)
                    tp = huc.Top + (huc.Height / 2)
                    .Item(Trim(huc.Value)) = Array(lf, tp)
                End If
            Next huc
            ilkNokta = Trim(rota(1))
            For i = 2 To UBound(rota)
                sonNokta = Trim(rota(i))
                If ilkNokta <> sonNokta And .exists(ilkNokta) And .exists(sonNokta) Then
                    aNok = .Item(ilkNokta)
                    bNok = .Item(sonNokta)
                    Sheets("Harita").Shapes.AddConnector msoConnectorStraight, aNok(0), aNok(1), bNok(0), bNok(1)
                    ilkNokta = sonNokta
                ElseIf ilkNokta = 0 Then
                    Exit Sub
                Else
                    MsgBox "Noktalardan birisi bulunamadı."
                End If
            Next i
        End With
    End With
End Sub

tamer42 · 14 Nisan 2023

veyselemre' Alıntı:

Kod:

Sub rota()
    Dim shp As Object, rota
    With Sheets("Harita")
        For Each shp In ActiveSheet.Shapes
            shp.Delete
        Next shp
    End With
    With Sheets("data")
        rota = Application.Index(.Range("B6:M6").Value, 0, 0)
        rotaCiz (rota)
        rota = Application.Index(.Range("B8:M8").Value, 0, 0)
        rotaCiz (rota)
    End With
End Sub

Sub rotaCiz(rota)
    Dim rng As Range, huc As Range, lf, tp, i, ilkNokta, sonNokta, aNok, bNok, shp, msg
    With Sheets("Harita")
        Set rng = .UsedRange
        With CreateObject("Scripting.Dictionary")
            For Each huc In rng
                If IsNumeric(huc.Value) Then
                    lf = huc.Left + (huc.Width / 2)
                    tp = huc.Top + (huc.Height / 2)
                    .Item(Trim(huc.Value)) = Array(lf, tp)
                End If
            Next huc
            ilkNokta = Trim(rota(1))
            For i = 2 To UBound(rota)
                sonNokta = Trim(rota(i))
                If ilkNokta <> sonNokta And .exists(ilkNokta) And .exists(sonNokta) Then
                    aNok = .Item(ilkNokta)
                    bNok = .Item(sonNokta)
                    Sheets("Harita").Shapes.AddConnector msoConnectorStraight, aNok(0), aNok(1), bNok(0), bNok(1)
                    ilkNokta = sonNokta
                ElseIf ilkNokta = 0 Then
                    Exit Sub
                Else
                    MsgBox "Noktalardan birisi bulunamadı."
                End If
            Next i
        End With
    End With
End Sub

Veysel Hocam çok teşekkürler,
emeğinize sağlık!

tamer42 · 15 Nisan 2023

veyselemre' Alıntı:

Kod:

Sub rota()
    Dim shp As Object, rota
    With Sheets("Harita")
        For Each shp In ActiveSheet.Shapes
            shp.Delete
        Next shp
    End With
    With Sheets("data")
        rota = Application.Index(.Range("B6:M6").Value, 0, 0)
        rotaCiz (rota)
        rota = Application.Index(.Range("B8:M8").Value, 0, 0)
        rotaCiz (rota)
    End With
End Sub

Sub rotaCiz(rota)
    Dim rng As Range, huc As Range, lf, tp, i, ilkNokta, sonNokta, aNok, bNok, shp, msg
    With Sheets("Harita")
        Set rng = .UsedRange
        With CreateObject("Scripting.Dictionary")
            For Each huc In rng
                If IsNumeric(huc.Value) Then
                    lf = huc.Left + (huc.Width / 2)
                    tp = huc.Top + (huc.Height / 2)
                    .Item(Trim(huc.Value)) = Array(lf, tp)
                End If
            Next huc
            ilkNokta = Trim(rota(1))
            For i = 2 To UBound(rota)
                sonNokta = Trim(rota(i))
                If ilkNokta <> sonNokta And .exists(ilkNokta) And .exists(sonNokta) Then
                    aNok = .Item(ilkNokta)
                    bNok = .Item(sonNokta)
                    Sheets("Harita").Shapes.AddConnector msoConnectorStraight, aNok(0), aNok(1), bNok(0), bNok(1)
                    ilkNokta = sonNokta
                ElseIf ilkNokta = 0 Then
                    Exit Sub
                Else
                    MsgBox "Noktalardan birisi bulunamadı."
                End If
            Next i
        End With
    End With
End Sub

Veysel Hocam kodun sonunda;
burada çizgileirn toplam uzunluğunu nasıl alabiliriz?
Teşekkürler,
iyi Akşamlar.

veyselemre · 15 Nisan 2023

Yatay çizgilerde; width , dikey çizgilerde; height, eğimli çizgilerde ise dik üçgen kuralına göre hipotenüsün uzunluğunu buldum, kendimce böyle bir çözüm düşündüm.

Kod:

Sub rota()
    Dim shp As Object, rota
    With Sheets("Harita")
        For Each shp In ActiveSheet.Shapes
            shp.Delete
        Next shp
    End With
    With Sheets("data")
        rota = Application.Index(.Range("B6:M6").Value, 0, 0)
        MsgBox rotaCiz(rota)

        rota = Application.Index(.Range("B8:M8").Value, 0, 0)
        MsgBox rotaCiz(rota)
    End With
End Sub

Function rotaCiz(rota)
    Dim rng As Range, huc As Range, lf, tp, i, ilkNokta, sonNokta, aNok, bNok, shp, msg, uz, topUz
    With Sheets("Harita")
        Set rng = .UsedRange
        With CreateObject("Scripting.Dictionary")
            For Each huc In rng
                If IsNumeric(huc.Value) Then
                    lf = huc.Left + (huc.Width / 2)
                    tp = huc.Top + (huc.Height / 2)
                    .Item(Trim(huc.Value)) = Array(lf, tp)
                End If
            Next huc
            ilkNokta = Trim(rota(1))
            For i = 2 To UBound(rota)
                sonNokta = Trim(rota(i))
                If ilkNokta <> sonNokta And .exists(ilkNokta) And .exists(sonNokta) Then
                    aNok = .Item(ilkNokta)
                    bNok = .Item(sonNokta)
                    Set shp = Sheets("Harita").Shapes.AddConnector(msoConnectorStraight, aNok(0), aNok(1), bNok(0), bNok(1))
                    If shp.Width = 0 Or shp.Height = 0 Then
                        uz = shp.Width + shp.Height
                    Else
                        uz = Sqr(shp.Width ^ 2 + shp.Height ^ 2)
                    End If
                    topUz = topUz + uz
                    ilkNokta = sonNokta
                ElseIf ilkNokta = 0 Then
                    rotaCiz = topUz
                    Exit Function
                Else
                    MsgBox "Noktalardan birisi bulunamadı."
                End If
            Next i
        End With
        rotaCiz = topUz
    End With

End Function

tamer42 · 15 Nisan 2023

veyselemre' Alıntı:

Yatay çizgilerde; width , dikey çizgilerde; height, eğimli çizgilerde ise dik üçgen kuralına göre hipotenüsün uzunluğunu buldum, kendimce böyle bir çözüm düşündüm.

Kod:

Sub rota()
    Dim shp As Object, rota
    With Sheets("Harita")
        For Each shp In ActiveSheet.Shapes
            shp.Delete
        Next shp
    End With
    With Sheets("data")
        rota = Application.Index(.Range("B6:M6").Value, 0, 0)
        MsgBox rotaCiz(rota)

        rota = Application.Index(.Range("B8:M8").Value, 0, 0)
        MsgBox rotaCiz(rota)
    End With
End Sub

Function rotaCiz(rota)
    Dim rng As Range, huc As Range, lf, tp, i, ilkNokta, sonNokta, aNok, bNok, shp, msg, uz, topUz
    With Sheets("Harita")
        Set rng = .UsedRange
        With CreateObject("Scripting.Dictionary")
            For Each huc In rng
                If IsNumeric(huc.Value) Then
                    lf = huc.Left + (huc.Width / 2)
                    tp = huc.Top + (huc.Height / 2)
                    .Item(Trim(huc.Value)) = Array(lf, tp)
                End If
            Next huc
            ilkNokta = Trim(rota(1))
            For i = 2 To UBound(rota)
                sonNokta = Trim(rota(i))
                If ilkNokta <> sonNokta And .exists(ilkNokta) And .exists(sonNokta) Then
                    aNok = .Item(ilkNokta)
                    bNok = .Item(sonNokta)
                    Set shp = Sheets("Harita").Shapes.AddConnector(msoConnectorStraight, aNok(0), aNok(1), bNok(0), bNok(1))
                    If shp.Width = 0 Or shp.Height = 0 Then
                        uz = shp.Width + shp.Height
                    Else
                        uz = Sqr(shp.Width ^ 2 + shp.Height ^ 2)
                    End If
                    topUz = topUz + uz
                    ilkNokta = sonNokta
                ElseIf ilkNokta = 0 Then
                    rotaCiz = topUz
                    Exit Function
                Else
                    MsgBox "Noktalardan birisi bulunamadı."
                End If
            Next i
        End With
        rotaCiz = topUz
    End With

End Function

[/

çok teşekkürler Veysel Hocam
iyi ki varsınız!

Rota Haritalama

tamer42

Destek Ekibi

Ekli dosyalar

veyselemre

Özel Üye

tamer42

Destek Ekibi

tamer42

Destek Ekibi

veyselemre

Özel Üye

tamer42

Destek Ekibi