Condividi:        

Modifica Macro

Vuoi potenziare i tuoi documenti Word? Non sai come si fa una macro in Excel? Devi creare una presentazione in PowerPoint?
Oppure sei passato a OpenOffice e non sei sicuro di come lavorare al meglio?

Moderatori: Anthony47, Flash30005

Modifica Macro

Postdi papiriof » 14/12/16 10:25

Da molto tempo che non riesco a modificare questa macro , sembrerebbe facile ma..
Cosa fa la macro? come dice il titolo propone 2 numeri in continuazione nelle celle A1 e B1 in continuazione ed esce,al verificarsi di una condizione,
il problema sorge quando qualche volta questa macro l'adatto in diverse altri file dove le celle A1 e B1 sono occupate ,quindi la richiesta è : come spostare a piacimento le celle ad esempio in D1 ed E1 o che so in M4 ed N4 mantenentdo inalterato quello che fa la macro? Il Massimo sarebbe che la macro proporrebbe (nelle celle suddette) tutti gli ambi possibili con 90 numeri (4005) adesso invece li propone in modo random e quindi impiega parecchio tempo prima che trovi l'ambo giusto per cui , soddisfatta la condizione esce..... comunque na cosa alla volta :) grazie per chi vorrà aiutarmi.
Public Sub Proponi2()
'Application.ScreenUpdating = False
Dim numeri(5) As Long
Dim A As Long
Dim b As Long
Do
For A = 1 To 2 ' riempie la matrice con numeri casuali
rifai:
numeri(A) = Int(Rnd * 90 + 1)
For b = 1 To 2 'controlla se c'è un numero doppio
If A = b Then GoTo salta
If numeri(A) = numeri(b) Then GoTo rifai
salta:
Next b
Next A
For A = 1 To 2 'riempie le celle
Cells(1, A) = numeri(A)
Next A
DoEvents
If Cells(1, 13) < Cells(1, 14) Then Exit Do 'Questa è la condizione
Loop
'Application.ScreenUpdating = True
End Sub
Win 7+Office 2010
papiriof
Utente Senior
 
Post: 392
Iscritto il: 16/02/10 13:23

Sponsor
 

Re: Modifica Macro

Postdi patel » 14/12/16 13:00

metti i numeri da 1 a 90 in colonna A e prova questa macro
Codice: Seleziona tutto
Sub combina2()
Dim N(), i As Integer, K As Byte, Comb As Collection
K = 2
Inizio = 1
LR = Cells(Rows.Count, "A").End(xlUp).Row
ReDim N(LR - Inizio)
For i = 0 To LR - Inizio
  N(i) = Cells(Inizio + i, 1)
Next
    Set Comb = CombinazioniSemplici(N, K)
    For i = 1 To Comb.Count
        Cells(i, 4) = Right(Comb(i), Len(Comb(i)) - 1)
    Next i
    MsgBox Comb.Count
End Sub

Public Function CombinazioniSemplici(ByVal arrayElementi As Variant, ByVal dimensioneGruppo As Byte) As Collection
    Dim LC As New Collection
    If UBound(arrayElementi) = 0 Then
        Set CombinazioniSemplici = LC
    End If
    If dimensioneGruppo = 0 Or dimensioneGruppo > UBound(arrayElementi) Then
        Set CombinazioniSemplici = LC
    End If
    Dim aP() As Integer
    ReDim aP(dimensioneGruppo - 1)
    Dim i As Integer
    For i = 0 To UBound(aP)
        aP(i) = i
    Next i
    Dim j As Integer
    Dim C As String
    Dim cnt As Integer
    Do
        C = ""
        For i = 0 To UBound(aP)
            C = C & " " & arrayElementi(aP(i))
        Next i
        LC.Add (C)
        cnt = 0
        For i = UBound(aP) To 0 Step -1
            If aP(i) = UBound(arrayElementi) - cnt Then
                cnt = cnt + 1
                If cnt = UBound(aP) + 1 Then Exit Do
            Else
                aP(i) = aP(i) + 1
                For j = 0 To UBound(aP)
                    If i < j Then aP(j) = aP(i) + (j - i)
                Next
                Exit For
            End If
        Next i
    Loop
    Set CombinazioniSemplici = LC
 
End Function
patel
Utente Senior
 
Post: 309
Iscritto il: 24/04/12 16:03

Re: Modifica Macro

Postdi papiriof » 14/12/16 17:36

Grazie pate ma non ci siamo avevo messo una risposta più esauriente ma mi hanno messo il modem nuovo e non so che fine ha fatto la precedente risposta , tornerò dopo.
Win 7+Office 2010
papiriof
Utente Senior
 
Post: 392
Iscritto il: 16/02/10 13:23

Re: Modifica Macro

Postdi papiriof » 15/12/16 08:27

Codice: Seleziona tutto
 http://www.filedropper.com/trovambimacro

provo ad inviare il file
Win 7+Office 2010
papiriof
Utente Senior
 
Post: 392
Iscritto il: 16/02/10 13:23

Re: Modifica Macro

Postdi papiriof » 15/12/16 09:08

Ogni volta mi scordo comunque penso che sono riuscito a inviare il file
In questo file , una volta che avete piazzato su M1 il numero di ambi che desiderate essere superato ,pigiato il bottone della macro,questa si fermerà quando in N1 apparirà un numero superiore a quello che avete messo in M1.
Quale è il problema? nell'intervallo A1:B1 dove si succedono velocemente gli ambi questi sono proposti in modo casuale per cui
se in M1 mettiamo un numero relativamente troppo grande rischiamo di aspettare chissà quanto tempo o perchè effettivamente
non ci sono un numero di ambi superiore a quelli indicati in M1 o se invece ci sono non vengono rilevati perchè la macro propone si velocemente gli ambi ma diciamo non "c'azzecca" mai a beccare quello/quelli giusti, quindi come come proporre tutti gi ambi possibili e se non trovato il num di ambi superiore a quelli indicati in M1 mi esca comunque dalla macro?
Secondo problema, come ho detto, in A1 e B1 è previsto che si succedano gli ambi ma se volessi cambiare intervallo invece di A1:B1 C1:D1, come modificare senza che cambi quello che fa attualmente la macro?
http://www.filedropper.com/trovambimacro_1
Win 7+Office 2010
papiriof
Utente Senior
 
Post: 392
Iscritto il: 16/02/10 13:23

Re: Modifica Macro

Postdi Anthony47 » 16/12/16 03:09

Questo codice simula tutti gli ambo in sequenza e riporta, da colonna N in avanti, tutte te coppie che producono piu' degli ambo indicati in M1.
Su riga 2 viene indicato: NumeriDiAmbo#PrimoEstratto#EsecondoEstratto; nella colonna sottostante vengono indicate le righe che producono il risultato
Dopo 100 risultati proposti la macro si interrompe comunque.
Il codice:
Codice: Seleziona tutto
Dim eArr, Resarr()          '<<< IN CIMA AL MODULO
Sub Simuler()
Dim E1 As Integer, E2 As Integer, Soglia As Integer, Last As Long

Last = Cells(Rows.Count, "B").End(xlUp).Row
eArr = Range(Range("B3"), Cells(Last, "F")).Value
Soglia = Range("M1").Value
Range("M2").Resize(Last + 100, 200).ClearContents
For E1 = 1 To 89
DoEvents
    For E2 = E1 + 1 To 90
        Call TrAmbo(E1, E2)
        If Resarr(1) > Soglia Then
            nextc = Cells(2, Columns.Count).End(xlToLeft).Column + 1
            If nextc < 14 Then nextc = 14
            Resarr(1) = Resarr(1) & "#" & E1 & "#" & E2
            Range(Cells(2, nextc), Cells(Last, nextc)).Value = Application.WorksheetFunction.Transpose(Resarr)
            If nextc > 100 Then GoTo fineZ
        End If
    Next E2
Next E1
fineZ:
MsgBox ("Completato...")
End Sub


Sub TrAmbo(ByVal NN1 As Integer, ByVal NN2 As Integer)
Dim pPoint As Integer, I As Long, J As Integer
Dim cAmb As Integer
Erase Resarr
ReDim Resarr(LBound(eArr, 1) To UBound(eArr, 1) + 1)
For I = LBound(eArr, 1) To UBound(eArr, 1)
    pPoint = 0
    For J = LBound(eArr, 2) To UBound(eArr, 2)
        If eArr(I, J) = NN1 Or eArr(I, J) = NN2 Then pPoint = pPoint + 1
    Next J
    If pPoint > 1 Then Resarr(I + 1) = 1: cAmb = cAmb + 1
Next I
Resarr(LBound(eArr, 1)) = cAmb
'TrAmbo = Resarr
End Sub

La macro da lanciare e' la Sub Simuler
La macro non usa la struttura di formule inserite nel foglio; le celle A1-B1 e la colonna L possono essere cancellate.

Ciao
Avatar utente
Anthony47
Moderatore
 
Post: 19181
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Modifica Macro

Postdi papiriof » 16/12/16 08:30

GRANDE ANTHONY non potevo chiedere di meglio !!! bella soluzione :D :D
Win 7+Office 2010
papiriof
Utente Senior
 
Post: 392
Iscritto il: 16/02/10 13:23


Torna a Applicazioni Office Windows


Topic correlati a "Modifica Macro":


Chi c’è in linea

Visitano il forum: Nessuno e 58 ospiti