Valutazione 4.87/ 5 (100.00%) 5838 voti

Condividi:        

prendere valori di celle

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

prendere valori di celle

Postdi miko » 23/03/13 20:41

salve,
con la macro "cerca ambi", già realizzata, trovo gli ambi su una riga in una tabella come in fig.

Immagine

l'ultima colonna utile è la colonna BE.
faccio notare che la riga 3, in cui vi sono i nomi delle ruote e formata da celle unite
per ogni nome di ruota.
via via che la macro "cerca ambi" trova gli ambi su due ruote
vorrei trasferire il risultato sul foglio 1 in modo da avere questo prospetto:

Immagine

il problema per ottenere il prospetto è la presenza di celle unite, ed il ciclo per
trasferire gli ambi trovati ad ogni ciclo.
per quanto riguarda le celle unite sono riuscito parzialmente a risolvere il problema,
anche se in maniera "articolata".
ho realizzato la seguente macro incompleta, con la quale prelevo gli ambi trovati in base al colore delle celle;
ma ciò non è una condizione indispensabile ai fini del risultato:

Codice: Seleziona tutto
Sub PRELEVACOLORATE()
Dim RNG As Range
Dim RNGUNI As Range
Dim rngStart As Range
Dim rngEnd As Range
Application.ScreenUpdating = False
Application.Calculation = xlManual
UR2 = Sheets("Foglio1").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Foglio1").Range("A1:C" & UR2).ClearContents
Worksheets("Archivio").Select
R = 6 'fisso la riga degli ambi  <<<<<<<<<<
RRuota = 3 'riga dei nomi delle ruote  <<<<<<<<<<<
Set RNG = Worksheets("Archivio").Range("C" & R & ":BE" & R)
For Each CEL In RNG
If CEL.Interior.ColorIndex <> xlNone Then
   ColCEL = CEL.Column
   Range("A1").Value = ColCEL
 'istruzioni per le celle unite  <<<<<<<<<<<<<
   Set RNGUNI = Cells(3, ColCEL)
  If RNGUNI.MergeCells Then
   Set RNGUNI = RNGUNI.MergeArea
   Set rngStart = RNGUNI.Cells(1, 1)
   Set rngEnd = RNGUNI.Cells(RNGUNI.Rows.Count, RNGUNI.Columns.Count)
   A = rngStart.Address(RowAbsolute:=False, COLUMNAbsolute:=False)
   B = rngEnd.Address(RowAbsolute:=False, COLUMNAbsolute:=False)
   Range("A12").Value = A
   Range("A13").Value = B
'trasferimento su foglio 1  <<<<<<<<<<<<<<
Worksheets("Foglio1").Cells(1, 1).Value = _
Worksheets("Archivio").Range((Range("A12").Value), (Range("A13").Value)).Value
Worksheets("Foglio1").Cells(1, 2).Value = _
Worksheets("Archivio").Cells(R, ColCEL).Value
  End If
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

questa macro funziona per le istruzioni in essa contenute ma non per il risultato che vorrei ottenere.
P.S. i numeri nel prospetto sono inseriti casualmente al solo scopo di mostrare il risultato che vorrei
ottenere e non ha alcuna corrispondenza con la tabella
saluti e grazie
windows xp-office 2003
miko
Utente Senior
 
Post: 422
Iscritto il: 29/12/09 10:44

Sponsor
 

Re: prendere valori di celle

Postdi Flash30005 » 23/03/13 23:17

Se aggiungi il Foglio1 al file precedente (con macro CercaAmboTutte)
e sostituisci la macro con questa dovresti risolvere
Codice: Seleziona tutto
Sub CercaAmboTutte()
Worksheets("Archivio").Select
Worksheets("Foglio1").Cells.Clear
UR = Worksheets("Archivio").Range("C" & Rows.Count).End(xlUp).Row
Range("C5:BE" & UR).Interior.ColorIndex = xlNone
For R = 6 To UR
AggR = 1
    For CC = 1 To 10
        RRP = CC * 5 + 2
        RRuota = RRP - 4
        For CA = RRuota To RRuota + 3
            A = Format(Cells(R, CA).Value, "00")
            For CB = CA + 1 To RRuota + 4
                B = Format(Cells(R, CB).Value, "00")
                Ambo = Val(A & B)
                If A > B Then Ambo = Val(B & A)
                For ColIn = 5 + RRuota To 53 Step 5
                For Col1 = ColIn To ColIn + 3
                    aa = Format(Cells(R, Col1).Value, "00")
                    For Col = Col1 + 1 To ColIn + 4
                        bb = Format(Cells(R, Col).Value, "00")
                        AmboE = Val(aa & bb)
                        If aa > bb Then AmboE = Val(bb & aa)
                        If AmboE = Ambo Then
                        UR1 = Worksheets("Foglio1").Range("A" & Rows.Count).End(xlUp).Row + 1 + AggR
                         Worksheets("Foglio1").Range("A" & UR1).Value = Worksheets("Archivio").Cells(3, RRuota).Value
                         UC1 = Worksheets("Foglio1").Cells(1, Columns.Count).End(xlToLeft).Column + 1
                         Worksheets("Foglio1").Cells(UR1, UC1).Value = Worksheets("Archivio").Cells(R, Col).Value
                         Worksheets("Foglio1").Cells(UR1, UC1 + 1).Value = Worksheets("Archivio").Cells(R, Col1).Value
                        If Cells(R, Col).Interior.ColorIndex = xlNone Then
                            Cells(R, Col).Interior.ColorIndex = 6
                        Else
                            Cells(R, Col).Interior.ColorIndex = 4
                        End If
                        If Cells(R, Col1).Interior.ColorIndex = xlNone Then
                            Cells(R, Col1).Interior.ColorIndex = 6
                        Else
                            Cells(R, Col1).Interior.ColorIndex = 4
                        End If
                        If Cells(R, CA).Interior.ColorIndex = xlNone Then
                            Cells(R, CA).Interior.ColorIndex = 45
                        Else
                            Cells(R, CA).Interior.ColorIndex = 41
                        End If
                        If Cells(R, CB).Interior.ColorIndex = xlNone Then
                            Cells(R, CB).Interior.ColorIndex = 45
                        Else
                            Cells(R, CB).Interior.ColorIndex = 41
                        End If
                        AggR = 0
                        End If
                Next Col
            Next Col1
        Next ColIn
        Next CB
        Next CA
    Next CC
Next R
End Sub



Ciao
Flash
Win7 + Office 2010 Ita
"Fotografica" al servizio dell'immagine

Ottime opportunità di lavoro (part-time o full-time) con guadagni immediati. Info in MP
Avatar utente
Flash30005
Moderatore
 
Post: 8460
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: prendere valori di celle

Postdi miko » 26/05/13 11:05

salve,
anche qui vale la premessa dell'altro topic.
ed anche in questo caso le macro che hai realizzato soddisfano
il problema.
grazie del tuo impegno.
buona domenica
windows xp-office 2003
miko
Utente Senior
 
Post: 422
Iscritto il: 29/12/09 10:44


Torna a Applicazioni Office Windows


Topic correlati a "prendere valori di celle":


Chi c’è in linea

Visitano il forum: Nessuno e 5 ospiti