con la macro "cerca ambi", già realizzata, trovo gli ambi su una riga in una tabella come in fig.
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:
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
