Stellar Blade Un'esclusiva PS5 che sta facendo discutere per l'eccessiva bellezza della protagonista. Vieni a parlarne su Award & Oscar!

Excel Forum Per condividere esperienze su Microsoft Excel

qualcuno può aiutarmi con questa macro

  • Messaggi
  • OFFLINE
    alessio del regno
    Post: 1
    Registrato il: 31/05/2023
    Età: 27
    Utente Junior
    2304
    00 31/05/2023 12:14
    qualcuno potrebbe aiutarmi con questa macro, non mi funziona e non riesco a capire qual è il problema
    Function CalcolaDistanza(lat1 As Double, lon1 As Double, lat2 As Double, lon2 As Double) As Double
    Const R As Double = 6371 ' Raggio medio della Terra in chilometri

    Dim dLat As Double
    Dim dLon As Double
    Dim a As Double
    Dim c As Double
    Dim d As Double

    ' Conversione da gradi a radianti
    lat1 = WorksheetFunction.Radians(lat1)
    lon1 = WorksheetFunction.Radians(lon1)
    lat2 = WorksheetFunction.Radians(lat2)
    lon2 = WorksheetFunction.Radians(lon2)

    ' Calcolo delle differenze di latitudine e longitudine
    dLat = lat2 - lat1
    dLon = lon2 - lon1

    ' Calcolo della distanza utilizzando la formula di Haversine
    a = Sin(dLat / 2) ^ 2 + Cos(lat1) * Cos(lat2) * Sin(dLon / 2) ^ 2
    c = 2 * WorksheetFunction.Atan2(Sqr(a), Sqr(1 - a))
    d = R * c

    CalcolaDistanza = d
    End Function
    Sub macro_ottimizzazione()
    Sheets("COORDINATE DONATORI").Select

    Dim numPunti As Integer
    Dim numFurgoncini As Integer
    Dim coordPunti As Range
    Dim coordFurgoncini As Range
    Dim distanzaMax As Double

    numPunti = WorksheetFunction.CountA(Range("B3:B122")) - 1 ' Numero di punti dati (escludendo l'intestazione)
    numFurgoncini = 0 ' Numero iniziale di furgoncini
    Set coordPunti = Range("C3:D" & numPunti + 2) ' Range delle coordinate dei punti dati
    distanzaMax = 3 ' Distanza massima consentita in km

    ' Calcola la distanza tra tutti i punti e assegna i furgoncini
    Do While numPunti > 0
    numFurgoncini = numFurgoncini + 1 ' Incrementa il numero di furgoncini
    Set coordFurgoncini = Range("G3:H" & numFurgoncini + 2) ' Range delle coordinate dei furgoncini

    ' Calcola la distanza tra i punti e i furgoncini e assegna i furgoncini ai punti più vicini
    For Each punto In coordPunti
    minDistanza = distanzaMax
    For Each furgoncino In coordFurgoncini
    distanza = CalcolaDistanzaEuclidea(punto, furgoncino)
    If distanza < minDistanza Then
    minDistanza = distanza
    punto.Offset(0, 2).Value = furgoncino.Offset(0, 2).Value ' Assegna l'etichetta del furgoncino al punto
    End If
    Next furgoncino
    Next punto

    numPunti = WorksheetFunction.CountIf(Range("E3:E122"), "") ' Conta i punti non assegnati a un furgoncino
    Loop
    End Sub

    Function CalcolaDistanzaEuclidea(coordPunti As Range, coordFurgoncini As Range) As Double
    ' Esempio: calcola la distanza euclidea tra due punti utilizzando le coordinate geografiche
    Dim deltaX As Double
    Dim deltaY As Double

    deltaX = coordFurgoncini.Offset(0, -2).Value - coordPunti.Offset(0, -2).Value ' Calcola la differenza tra le coordinate X
    deltaY = coordFurgoncini.Offset(0, -1).Value - coordPunti.Offset(0, -1).Value ' Calcola la differenza tra le coordinate Y

    CalcolaDistanzaEuclidea = Sqr(deltaX ^ 2 + deltaY ^ 2) ' Calcola la distanza euclidea utilizzando il teorema di Pitagora

    End Function
  • OFFLINE
    rollis13
    Post: 1.335
    Registrato il: 16/08/2015
    Città: CORDENONS
    Età: 67
    Utente Veteran
    Excel 2016-32bit Win11
    00 31/05/2023 18:13
    Re:

    non mi funziona

    E dovremmo noi capire cosa non funziona ?! almeno spiega qual è l'obiettivo del progetto, come si usa la macro ed in base a cosa affermi che non funziona oltre a specificare, se è la macro che si interrompe, a quale riga e con quale diagnostica.

    Ps. e nemmeno si pretende un esempio di file ridotto al minimo (poche righe di dati) e senza dati sensibili.

    [Modificato da rollis13 31/05/2023 18:21]

    ______________________________________________________________
    C'è chi fa le COSE a CASO e chi fa CASO alle COSE (Ignoto)
  • OFFLINE
    tanimon
    Post: 1.578
    Registrato il: 27/06/2011
    Utente Veteran
    excel 2007
    00 31/05/2023 21:32
    ciao,
    bella domanda.....

    Scusami tanto,
    ma questa sera sono stranamente di buon umore.....

    Non è che potrei avere una domanda di riserva od un aiutino....?!?!?!?

    🤣🤣🤣🤣🤣

    Buona serata
    Frank







    Stretta la foglia, larga la via, dite la vostra che ho detto la mia.
    Excel 2007 forse anche 2013 ... 2021 ... 365 e future...