differenza numeri

[miko]

Buona sera a tutti,
similmente al topic “TROVARE DEI VALORI CHE SOMMATI TRA LORO DANNO UN CERTO R”
inserendo dei numeri positivi in colonna B, disposti in ordine casuale e non necessariamente in ordine crescente,
è possibile determinare quei numeri di colonna B, tali che la loro differenza sia uguale ad un numero assegnato?
date le mie conoscenze e vedendo le macro del topic citato è per me un impresa titanica, tenuto conto che la
differenza può risultare negativa, mentre il risultato deve essere sempre positivo.
saluti e grazie

[Anthony47]

Immagino che fai riferimento alla macro citata qui: viewtopic.php?f=26&t=99473&p=575188#p574285 (ma derivata da una discussione piu' vecchia: viewtopic.php?f=26&t=94323#p539509)

Essa determina quali numeri di un insieme di N numeri, calcolati a gruppi di 1, di 2, di 3, ... di N, danno una certa somma.
Il caso che poni e' molto piu' semplice perche' si tratta di calcolare una differenza tra ognuno dei numeri e ognuno dei restanti (quindi sempre a coppie) e controllare se il risultato e' quello impostato.
Potresti usare una macro come questa:

Codice: Seleziona tutto

Sub Differenze()
Dim myStart As String, myDiff As String, I As Long, J As Long
Dim myLast As Long, myCol As Long
'
myStart = "A2"   '<< La cella in cui comincia l' elenco
myDiff = "B1"    '<< La cella in cui e' scritta la differenza da cercare
'
myLast = Range(myStart).End(xlDown).Row
myCol = Range(myStart).Column
Range(Range(myStart).Offset(0, 1), Cells(myLast, myCol + 1).Resize(, Columns.Count - myCol)).ClearContents
For I = Range(myStart).Row To myLast '- 1
'    For J = I + 1 To myLast
    For J = Range(myStart).Row To myLast
        If Abs(Cells(I, myCol) - Cells(J, myCol)) = Range(myDiff).Value Then
            Cells(I, Columns.Count).End(xlToLeft).Offset(0, 1) = Cells(J, myCol)
        End If
    Next J
Next I
End Sub


Personalizzare le istruzioni marcate << e poi eseguire: accanto a ogni numero dell' elenco saranno riportati, in orizzontale, i numeri quella differenza.
ATTENZIONE: le colonne adiacenti all' elenco saranno tutte AZZERATE senza preavviso prima di ricercare le coppie di numero.

Prova e fai sapere.

Ciao

[miko]

salve e buona domenica;

Il caso che poni e' molto piu' semplice ...

pensavo invece fosse molto più complicato ;
citando una tua espressione in un mio topic di qualche tempo addietro:
io(miko) "elaboro" mentalmente le cose complicate ed a voi(forum) lascio il compito più semplice di realizzare le macro ;
per quanto attiene al codice, anche in questo caso evidenzio la velocità, un codice conciso e la facile interpretazione del risultato
finale data la tua scelta di porre:

...accanto a ogni numero dell' elenco saranno riportati, in orizzontale, i numeri quella differenza.

ottimo lavoro, grazie.
in questi giorni riflettevo sulla possibilità di modificare il codice per evitare di inserire un solo numero in cella B1, come attualmente richiede la macro, ma di inserire più numeri contemporaneamente, in diverse celle, e ricercare la differenza di ciascuno di essi.
ho fatto delle prove inserendo in riga 1 a partire da B1 diversi valori;
modificando nel codice il riferimento: myDiff = "B1", in myDiff = "C1" oppure myDiff = "D1" etc
e commentando la linea che cancella le celle, mi sono accorto che in alcuni casi il risultato si sovrappone
a quello precedente, e perciò questa soluzione non può funzionare.
ho pensato allora di inserire in colonna A i numeri dell'elenco, in colonna B i numeri dei quali si cercano le differenze,
e di generare, per ciascun numero di colonna B, un foglio su cui riportare il risultato.
al momento in cui scrivo non ho altre idee risolutive e non intuisco se questa sia la soluzione migliore per una buona visualizzazione del risultato.
speriamo che la notte porti consiglio anche a te.
ciao e grazie

[Anthony47]

Non so quale e' l' uso di questo lavoro, quindi prendo per buona l' ipotesi di creare tanti fogli con le differenze tra un elenco di numeri e un elenco di differenze.
Ho immaginato che l' elenco dei numeri sia a destra dell' elenco delle differenze; questo per semplificarmi la vita nella scrittura dei risultati. Quindi, ad esempio, lista numeri in B2 e sottostanti, lista differenza in A2 e sottostanti.
Ho modificato la vecchia Sub Differenza e aggiunto una Sub multidiff, che e' quella da lanciare.
Il codice:

Codice: Seleziona tutto

Sub Differenza(ByVal DifF As Long)
Dim myStart As String, myDiff As String, I As Long, J As Long
Dim myLast As Long, myCol As Long
'
myStart = "B2"   '<< La cella in cui comincia l' elenco
'myDiff = "B1"    '<< La cella in cui e' scritta la differenza da cercare
myLast = Range(myStart).End(xlDown).Row
myCol = Range(myStart).Column
Range(Range(myStart).Offset(0, 1), Cells(myLast, myCol + 1).Resize(, Columns.Count - myCol)).ClearContents
For I = Range(myStart).Row To myLast '- 1
'    For J = I + 1 To myLast
    For J = Range(myStart).Row To myLast
'        If Abs(Cells(I, myCol) - Cells(J, myCol)) = Range(myDiff).Value Then
        If Abs(Cells(I, myCol) - Cells(J, myCol)) = DifF Then
            Cells(I, Columns.Count).End(xlToLeft).Offset(0, 1) = Cells(J, myCol)
        End If
    Next J
Next I

End Sub

Sub multidiff()
Dim mySource As String, myDiff As String, DifF
mySource = "Foglio1"   '<< Il foglio con l' elenco e le differenze
myDiff = "A2:A50"       '<< L' intervallo con le differenze
'
Sheets(mySource).Select
For I = Worksheets.Count To ActiveSheet.Index + 1 Step -1
'    Application.DisplayAlerts = False     '<< Vedi Testo
    Sheets(I).Delete
Next I
Application.DisplayAlerts = True
'
For Each DifF In Range(myDiff)
    If DifF <> 0 Then
        Differenza (DifF)
        Sheets(mySource).Copy After:=Sheets(Worksheets.Count)
        ActiveSheet.Name = "Diff-" & DifF
        Sheets(mySource).Select
    End If
Next DifF
End Sub


Come sempre vanno personalizzate le linee marcate <<

Per ognuna delle differenze in elenco si calcola quali numeri in elenco soddisfano, come nel caso precedente; quindi si creano tanti fogli con il risultato, e il foglio viene nominato "Diff-xy", dove "xy" e' la differenza calcolata.
Poiche' si aggiungono fogli, e' anche necesario ELIMINARLI prima dell' inizio; infatti la macro elimina SENZA PREAVVISO tutti i fogli che si trovano alla destra del foglio dichiarato "mySource". Ho lasciato attivo il warning che si stanno per cancellare dei fogli, per cui se vi rendete conto che succederebbe qualcosa di indesiderato rispondete "Annulla" e i fogli non saranno eliminati (ma la macro andra' poi in errore per tentativo di nominare due fogli con lo stesso nome).
Volendo potete eliminare il warning togliendo l' apostrofo in testa alla riga Application.DisplayAlerts = False '<< Vedi Testo

Ciao

[miko]

buona sera e buon weekend a tutti;
ho riletto più volte la tua ultima risposta poichè ero perplesso su:

Non so quale e' l' uso di questo lavoro, quindi prendo per buona l' ipotesi di creare tanti fogli con le differenze ...

il mio intento era quello di determinare tra i numeri di colonna B quelli che per differenza danno i numeri di colonna A;
... e ci sei riuscito.
data la mia limitata immaginazione ho pensato, e ad oggi non elaboro diversamente, che per una più chiara visualizzazione del risultato era "necessario" impiegare più fogli;
forse la tua, sicuramente più fervida, potrebbe escogitare una differente visualizzazione.
relativamente alla tua ultima macro, che funziona perfettamente, mi è tutto chiaro nelle sue
istruzioni.
grazie, ciao

[Anthony47]

Dipende da che cosa devi farci con quei numeri...
Per esempio, se devi solo dare uno sguardo ai risultati potresti operare sullo stesso foglio dove sono presenti sia l' elenco dei numeri che l' elenco delle differenze, facendo in modo che l' elenco sia visualizzato dinamicamente a seconda di quale differenza venga selezionata.
Per pura curiosita' ho adattato le macro precedenti (che vanno in un Modulo standard, es Modulo1) aggiungendo due macro di Worksheet_Change e Worksheet_SelectionChange che servono per governare il ricalcolo e la presentazione dei dati (e che vanno nel "modulo di codice" del foglio che contiene gli elenchi sui cui si lavora). Nessuna macro va lanciata a mano.
Il codice delle macro standard, che sostituiscono le macro precedenti:

Codice: Seleziona tutto

'QUESTE VANNO OBBLIGATORIAMENTE IN CIMA AL MODULO
Public myStart As String, myLast As Long, myCol As Long
Public myArres() As Variant
Public Const myDiff As String = "A2:A10"  '<< L' intervallo con le differenze

Sub Differenza2(ByVal DifF As Long)
Dim I As Long, J As Long
'
Range(Range(myStart).Offset(0, 1), Cells(myLast, myCol + 1).Resize(, Columns.Count - myCol)).ClearContents
For I = Range(myStart).Row To myLast '- 1
    For J = Range(myStart).Row To myLast
        If Abs(Cells(I, myCol) - Cells(J, myCol)) = DifF Then
            Cells(I, Columns.Count).End(xlToLeft).Offset(0, 1) = Cells(J, myCol)
        End If
    Next J
Next I
End Sub
Sub multidiffArr()
Dim mySource As String, DifF
'
myStart = "B2"          '<< La cella in cui comincia l' elenco
mySource = "Foglio12"   '<< Il foglio con l' elenco e le differenze
'
Sheets(mySource).Select
myLast = Range(myStart).End(xlDown).Row
myCol = Range(myStart).Column
'(eliminato il codice che cancellava i fogli)
'
ReDim myArres(1 To Range(myDiff).Rows.Count)
Range(myStart).Offset(-1, 1).Value = "Ricalcolo della matrice in corso...."
For Each DifF In Range(myDiff)
    jJ = jJ + 1
    If DifF <> 0 Then
        Differenza2 (DifF)
        myArres(jJ) = Application.Intersect(Range(myStart).CurrentRegion, Range(Range(myStart).Offset(0, 1), Cells(myLast, myCol + 1).Resize(, Columns.Count - myCol))).Value
    End If
Next DifF
Range(myStart).Offset(-1, 1).Value = "<<< Elenco delle differenze >>>"

End Sub


Queste le macro di Change e SelectionChange:

Codice: Seleziona tutto

Private Sub Worksheet_Change(ByVal Target As Range)
If Application.Intersect(Target, Range(myDiff)) Is Nothing Then Exit Sub
ReDim myArres(0)
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim AaA
'myDiff = "A2:A10"      '<< L' intervallo con le differenze
If Application.Intersect(Target, Range(myDiff)) Is Nothing Or Target.Count > 1 Then Exit Sub
On Error Resume Next
AaA = UBound(myArres, 1)
On Error GoTo 0
If IsEmpty(AaA) Or AaA = 0 Then Call multidiffArr
Range(Range(myStart).Offset(0, 1), Cells(myLast, myCol + 1).Resize(, Columns.Count - myCol)).ClearContents
Range(myStart).Offset(-1, 1).Value = "<<< Elenco per Delta = " & Target.Value & " >>>"
If Target.Value <> 0 Then
    Mioff = Application.Match(Target.Value, Range(myDiff), 0)
    Range(myStart).Offset(0, 1).Resize(UBound(myArres(Mioff), 1), UBound(myArres(Mioff), 2)).Value = myArres(Mioff)

End If
End Sub


Come nella soluzione suggerita qualche giorno fa, l' elenco delle differenze va posizionato alla sinistra dell' elenco principale dei numeri; INOLTRE e' necessario che questi elenchi partano NON dalla prima riga (che verra' usata per inserire delle intestazioni variabili.
Questo e' un esempio di comportamento: selezionando un valore nell' elenco delle differenze verranno mostrati i risultati di quella scelta.


Uploaded with ImageShack.us

E' un dimostrativo, non garantisco che sia error free (anzi, mi sento di garantire il contrario )

Ciao

[miko]

salve,
ho notato solo ora che hai inserito un altro post;
con:

Non so quale e' l' uso di questo lavoro, quindi prendo per buona l' ipotesi di creare tanti fogli ...

avevo pensato che ad una tua differente visualizzazione del risultato oopure ad un deverso modo di procedere, e
non all'impiego della macro.
in effetti come hai evidenziato non ho ideato alcun tipo di impiego e rimane una macro a se stante, utile al fine di vedere il risultato delle differenze.
dopo la tua macro delle somme avevo pensato anche alle differenze.
per quanto attiene al tuo ultimo codice, interessante l'introduzione degli eventi change e selectionchange,
non ho provato,visto che noto solo ora la tua risposta, ma sicuramente mi incuriosisce questa nuova versione
ed appena posso faccio il test e verifico se come affermi non è error free, anche se ci credo poco.
per intanto tante grazie dei tuoi contributi a questo topic.
ciao

[miko]

salve a tutti,
nello sviluppo di questo topic mi aveva incuriosito una tua citazione, contenuta nella risposta del 19/08/13:

Essa determina quali numeri di un insieme di N numeri, calcolati a gruppi di 1, di 2, di 3, ... di N, danno una certa somma.
Il caso che poni e' molto piu' semplice perche' si tratta di calcolare una differenza tra ognuno dei numeri e ognuno dei restanti (quindi sempre a coppie) e controllare se il risultato e' quello impostato

.
nel caso da te risolto, il numero 18, ad esempio, può essere ottenuto come differenza tra 20 e 2:
18=20-2 , quindi, come avevi impostato, con coppie di numeri;
ma lo stesso numero 18 può anche essere ottenuto come differenza tra più numeri:
ad esempio:
18=36-6-5-4-3;
in quest'ultimo ipotesi si potrebbe adattare-modificare il codice che hai realizzato per il caso delle somme, oppure bisogna realizzare una macro ex-novo?
ciao e grazie

[Anthony47]

Un risultato puo' essere ottenuto tramite infinite sottrazioni diverse (al contrario della somma, dove qualsiasi addendo superiore al risultato non e' ammissibile).
Quindi devi delimitare il campo di variabilita', altrimenti il ti troveresti con una macro che non si fermera' mai...
Forse stai parlando di cercare le combinazioni in un elenco di valori? In questo caso puoi fare un esempio di dati di partenza con i dati che vorresti calcolare?
In generale, una macro fa una cosa ben specifica, ma fortuntamente dato un problema risolvibile si trova spesso una soluzione.

Ciao

[miko]

buona sera,
riesco a comprendere che:

Un risultato puo' essere ottenuto tramite infinite sottrazioni diverse ...

e che se non si pone un limite si incorre nell'eventualità:

..ti troveresti con una macro che non si fermera' mai

non riesco però a definire questo limite o campo di variabilita' di cui scrivi,
forse perchè non avevo pensato a questa tua soluzione;
hai stimolato la mia curiosità, forse se fai un piccolo esempio mi sarà più chiaro.

avevo immaginato invece, come hai intuito,qualcosa di simile alla somma:

Forse stai parlando di cercare le combinazioni in un elenco di valori

inserire in colonna A dei valori e ricercare in colonna B quei numeri che per differenza
forniscono il numero in A;
allego un piccolo esempio
http://www.filedropper.com/differenzapinumeri
ciao e grazie

[Anthony47]

se fai un piccolo esempio mi sarà più chiaro.

Avendo concluso che l' obiettivo e' ricercare i risultati tra un elenco definito di numeri dovresti gia' avere l' esempio di cosa intendevo per "delimitare il campo di variabilità"

Per provare a darti una risposta ho modificato la macro CercaComb utilizzata in altre discussioni, facendola diventare una subordinata di una nuova macro (Sub CercaDiff), che usa CercaComb per cercare quali combinazioni possono avere la differenza impostata rispetto a uno dei valori dell' elenco; la nuova macro si occupera' di scansionare tutti i valori in elenco e per ognuno calcolare le possibili combinazioni.
Il codice complessivo e':

Codice: Seleziona tutto

Dim VArr, WkArr(), WkIndex(), I As Integer, J As Integer, maxCol As Long, FlExit As Boolean
Dim Kappa As Integer, WResult As String, TgVal As Long, LastLev As Long, II As Long, NElem As Integer
Dim myCCurr As Long, DataCol As Long, maxCombin As Long

Sub CercaDiff()
'V1 B31018
'
Dim diffVal As Long, xyI As Long
DataCol = 2         '<<< La colonna che contiene i dati da esaminare; 1=A, 2=B, etc
maxCol = 200         '<<<  N° max di match
maxCombin = 20000000   '<<<  N° max di combinazioni che saranno testate

VArr = Range(Cells(2, DataCol), Cells(Rows.Count, DataCol).End(xlUp))
NElem = UBound(VArr, 1)
ReDim WkArr(NElem): ReDim WkIndex(NElem)
Cells(1, DataCol + 1).Resize(NElem + 1, Columns.Count - 1 - Cells(1, DataCol).Column).Clear

diffVal = InputBox("Valore Differenza (intero positivo)?")
sTimer = Timer
For xyI = 2 To NElem
    If Cells(xyI, DataCol) > diffVal Then
        Call CercaCombV1(Cells(xyI, DataCol), diffVal)
    End If

Next xyI

MsgBox ("Completato in " & Format(Timer - sTimer, "0.0") & " Secondi" & vbCrLf & "Rilevati " & _
    Application.WorksheetFunction.CountA(Cells(1, DataCol).Resize(1, Columns.Count - DataCol - 1 - 1)) _
    & " match" & vbCrLf & mexflex)

End Sub


Sub CercaCombV1(ByVal myCurr As Long, myDiff As Long)
'Rev. 1
'B31018
myCCurr = myCurr
TgVal = myCurr - myDiff

Dim Col2H As Double, Col2K As Double
'
''DataCol = 2         '<<< La colonna che contiene i dati da esaminare; 1=A, 2=B, etc
''maxCol = 23         '<<<  N° max di match
''maxCombin = 20000000   '<<<  N° max di combinazioni che saranno testate
'
FlExit = False
If maxCol > Columns.Count Then maxCol = Columns.Count - 3
''TgVal = (InputBox("Valore target?"))
''TgVal = Val(Replace(TgVal, ",", "."))    'Gestisce decimale sia "punto" che "virgola"
''VArr = Range(Cells(2, DataCol), Cells(Rows.Count, DataCol).End(xlUp))
''NElem = UBound(VArr, 1)
''ReDim WkArr(NElem): ReDim WkIndex(NElem)
''Cells(1, DataCol + 1).Resize(NElem + 1, Columns.Count - 1 - Cells(1, DataCol).Column).Clear
'
LastLev = 3
For I = 1 To NElem - 1
'modificato per calcolare anche il tot delle combinazioni (uso di Col2K e II)
    Col2H = Col2H + Evaluate("FACT(" & NElem & ")/FACT(" & I & ")/FACT(" & NElem - I & ")")
    If Col2H <= maxCombin Then Col2K = Col2H - 1: II = I
    If Col2H <= maxCombin Then Gruppidi = Gruppidi & " " & I
Next I

'Rispo = MsgBox("Il valore target e': " & TgVal _
        & vbCrLf & "Impostato max combinazioni: " & Round(MaxCombin / 1000000, 1) & " Milioni" _
        & vbCrLf & "N° di combinazioni massime che saranno testate: " & Col2K - _
        Evaluate("FACT(" & NElem & ")/FACT(" & I & ")/FACT(" & NElem - I & ")") & vbCrLf _
        & "(Combinazione di " & NElem & " elementi a gruppi di " & Gruppidi & ")" & vbCrLf _
        & "Massimo " & maxCol & " risultati" & vbCrLf _
        & "(Corrispondente al " & Int(Col2K / Col2H * 100) & "% delle possibili combinazioni)" & vbCrLf _
        & vbCrLf & "OK per procedere, CANCEL per annullare e modificare i parametri", vbOKCancel)
       

If Rispo = vbCancel Then Exit Sub
UserForm1.Show vbModeless
''sTimer = Timer
'
If TgVal = 0 Then GoTo ZeroVal
'
For LastLev = 1 To II + 1
    For J = 0 To NElem
        WkArr(J) = "": WkIndex(J) = ""
    Next J
    Call Recur(1, NElem, 1)
DoEvents                           '???
Next LastLev
If FlExit = True Then mexflex = "(stop per limite di colonne massime da riportare)"
ZeroVal:
Unload UserForm1
''MsgBox ("Completato in " & Format(Timer - sTimer, "0.0") & " Secondi" & vbCrLf & "Rilevati " & _
    Application.WorksheetFunction.CountIf(Range("1:1"), "x") _
    & " match" & vbCrLf & mexflex)
End Sub

Sub Recur(ByVal Iniz As Integer, ByVal Final As Integer, ByVal myLevel As Integer)
Dim myI As Integer, myK As Integer
For myI = Iniz To (Final - LastLev + myLevel)
GoTo XYz
aaa = WkArr(1): bbb = WkIndex(1)
aaa = WkArr(2): bbb = WkIndex(2)
aaa = WkArr(3): bbb = WkIndex(3)
aaa = WkArr(4): bbb = WkIndex(4)

XYz:
    WkArr(myLevel) = VArr(myI, 1)
    WkIndex(myLevel) = myI
'aaa = Application.WorksheetFunction.Sum(WkArr())
    If myLevel = LastLev Then 'Or (Round(Application.WorksheetFunction.Sum(WkArr()), 3)) > Round(TgVal, 3) Then
'If Application.WorksheetFunction.Sum(WkArr()) > 161270.7 Then Stop
'aaa = Application.WorksheetFunction.Sum(WkArr())

        If Round(Application.WorksheetFunction.Sum(WkArr()), 3) = Round(TgVal, 3) And FlExit = False Then
            Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1) = myCCurr
            mycol = Cells(1, Columns.Count).End(xlToLeft).Column
            If mycol > maxCol Then FlExit = True
            For myK = 1 To LastLev
                Cells(WkIndex(myK) + 1, mycol) = 1 'WkIndex(myK)
            Next myK
        End If
    Else
        If Round(Application.WorksheetFunction.Sum(WkArr()), 3) > TgVal Then
'            Stop
            GoTo SkNxLev
'            Exit For
        End If
        Call Recur(myI + 1, NElem, myLevel + 1)
    End If
If FlExit = True Then Exit For
SkNxLev:
Next myI

WkArr(myLevel) = ""

End Sub

Va tutto inserito in un modulo esclusivo per questo set

L' elenco dei valori da considerare va messo in colonna B, da B2 verso il basso.
Le differenze saranno da inserire manualmente in un inputbox che si apre quando si lancia la macro CercaDiff (l' unica che puo' essere avviata dall' Utente).
I risultati saranno presentati sotto forma di matrice verticale che elenca in riga 1 il valore di partenza e nelle righe sottostanti una "1" sui valori da sottrarre al valore di partenza.
Come da esempio, che ha cercato per differenza=6 ottenendo 120 combinazioni:


Uploaded with ImageShack.us

Spero sia di qualche utilita'

Ciao