Selezionate le celle mettere in ordine con precisi criteri

[ikwae]

Gentilissimo Anthony ….

Anthony47 ha scritto: Però tu non puoi chiederci di andare a leggere tra le righe degli allegati per
capire che cosa stai chiedendo...

Ma come fa a chi mi aiuta a sapere cosa deve dare? Non mi risulta che abbia la sfera di cristallo!!
L’ho scritto per auto ammonirmi perché dici cose giuste dato che scrivo temi e confondo chi mi
aiuta mia culpa e mia culpa … anche se è una battuta spiritosa e, non offensiva, sono armai diverse
volte che ci casco vorrei spiegare le cose dettagliate per non far perdere tempo a chi mi aiuta
ma creo solo confusione e poi arrivano le naturali lamentele…

Anthony47 ha scritto: Ma se la guardi bene vedrai che non è come ti aspettavi, con i parametri giusti
Comunque hai fatto bene ad andare avanti da solo!

Prima che tu scrivessi questa soluzione di codice io non l’avevo ancora letta e sicuramente è giusta ci mancherebbe … ma io come idea l’avevo scartata perché non riuscivo a capire come mettere due “_”
e non 4 e quindi anche allo spazio del terno e a quello dopo e avevo scartato l’idea …
ma dato che c’è l’ho usata anche se ho lasciato le prove di quello che dico di aver fatto è nel
codice dell’allegato un modulo c’è “esecuzione alternativa” basta selezionare una cella e mandarlo in esecuzione per vedere la soluzione adottata. Felice come non mai per l’esito raggiunto ho realizzato
un foglio da allegare per la rete e finito il foglio funzionava a volte si e a volte no e ho preferito
adottare la tua sicura, certa e stabile soluzione.

Anthony47 ha scritto: Per tutto questo credo sia equo un compenso pari al 10% delle vincite (delle perdite non voglio sentire parlare, neh?)
Anthony47 ha scritto: Quanto ai Navigli, stai tranquillo che prima o poi ti facciamo pagare tutto

Ho sempre dichiarato di poter dare un contributo ad ogni genere di gradimento… Adesso come aprono
le “Frontiere Regionali” hai tutto il necessario per poterlo avere sia da solo che con tutto il Team!!

A proposito del lavoro che hai realizzato penso che sarà scritto sui libri di Storia un programma a 360°
che divide qualsiasi stringa, testo o quello che si ha in mente di fare. Un potente “manipolatore” di tutto.

Allego il file molto sintetico da usare, ma “potente” nella struttura, selezionare una cella e cliccare
a iosa sui pulsanti per notare i vari ordinamenti scritti a dx di ogni pulsante… Per i ringraziamenti
più concreti usa quello che hai a disposizione e per adesso come acconto Cordialmente ikwae.

http://www.filedropper.com/selezionefinitele5macrorete

[Anthony47]

A proposito del lavoro che hai realizzato penso che sarà scritto sui libri di Storia un programma a 360°
che divide qualsiasi stringa, testo o quello che si ha in mente di fare. Un potente “manipolatore” di tutto

Qui ti eri gia' fatto un mojito di troppo

sono armai diverse volte che ci casco vorrei spiegare le cose dettagliate per non far perdere tempo a chi mi aiuta
ma creo solo confusione e poi arrivano le naturali lamentele…

Prima o poi arriveremo anche alle punizioni corporali, stai attento

Ho notato che hai replicato in ogni modulo anche la Sub FNorm e la Sub SSort, che invece potevano rimanere su uno solo dei Moduli e sarebbero regolarmente state disponibili a tutte le varie Sub Registrata_xxx
Tienilo presente in un prossimo editing del file.

Ciao

[ikwae]

Gentilissimo Anthony ….
Per rispetto a chi legge due pagine e giusto che allego il codice completo corretto e funzionante al 100% perché altrimenti la Storia finisce fra qualche giorno quando non sarà più disponibile il file allegato. In aggiunta il codice per la ruota finale. Terrò in mente le tue ultime info per la Sub FNorm e la Sub SSort.
………….
Per ultimo anche se non è da titolo se puoi fare uno strappo alla regola, non serve un codice serve solo
un’indicazione. Se non puoi aprirò una richiesta di aiuto. Espongo brevemente.
Selezionata quest’area, all’interno della selezione, copiare la prima riga (44 74 54 84) e incollare ad esempio in D10 copiare la seconda riga (78 84 11 58) e incollarla ad esempio in C20 e così per le altre due righe …

Codice: Seleziona tutto

44   74   54   84
78   84   11   58
40   54   84   11
76   15   85   29

A ma serve l’istruzione o riga di codice per selezionare, all’interno di una selezione, la prima riga, poi la seconda e così via… Inutile dirti che da anni cerco questa istruzione in rete. Milioni di copia incolla in tutte le salse ma nessuna all’interno di una selezione. Oggi il bisogno è aumentato notevolmente.
Ringraziandoti mille e mille volte per il tuo prezioso aiuto e la tua pazienza. Cordialmente ikwae

Codice: Seleziona tutto

Sub Registrata_Con_Trattino_Matrice()
Application.ScreenUpdating = False
Dim wArr, newSh As Worksheet, StSh As Worksheet
'RUOTA INIZIALE
'keyS = Array(2.1) 'CRESCENTE
'keyS = Array(2.2) 'DECRESCENTE

'GRUPPI
'keyS = Array(3.1) 'CRESCENTE
'keyS = Array(3.2) 'DECRESCENTE

'CINQUINE
'keyS = Array(4.1) 'CRESCENTE
'keyS = Array(4.2) 'DECRESCENTE

'CONCORSO
'keyS = Array(6.1) 'CRESCENTE
'keyS = Array(6.2) 'DECRESCENTE

'RUOTA FINALE
'keyS = Array(7.1) 'Non usato(Ambi-Terni)
'keyS = Array(8.1)  'Ruota Finale
'
    Set StSh = ActiveSheet
    Selection.Cells(1, 1).Select
    Range(Selection, Selection.End(xlDown)).Copy
    Sheets.Add
    Set newSh = ActiveSheet
'
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.Replace What:="_", Replacement:=" ", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False ', FormulaVersion:=xlReplaceFormula2 '********REMMATO COME RICHIESTO
   
    Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
        Array(7, 1), Array(8, 1), Array(9, 1)), TrailingMinusNumbers:=True
'Stop               '???Decodifica tracciato
Call BNorm(1)
'Call CNorm
Call FNorm(1)
Call SSort(keyS)
wArr = newSh.Range(Range("A1"), Range("A1").End(xlDown)).Value

For I = 1 To UBound(wArr)
    wArr(I, 1) = Replace(wArr(I, 1), " ", "_", 1, 2, vbTextCompare)
Next I

Application.DisplayAlerts = False
newSh.Delete
Application.DisplayAlerts = True
StSh.Select

'COMPILA AREA DEI RISULTATI:
'Selection.Cells(1, 2).Resize(UBound(wArr), 1).Value = wArr  'Ipotesi colonna Adiacente
 Selection.Cells(1, 1).Resize(UBound(wArr), 1).Value = wArr 'Ipotesi RIMPIAZZA
Beep
Application.ScreenUpdating = False

End Sub
[/quote]
Sub BNorm(Dummy)
Range(Range("B1"), Range("B1").End(xlDown)).Select
    Selection.Replace What:="RN", Replacement:="ZZ", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
End Sub

Sub FNorm(Dummy)
Dim wArr, I As Long, cWA As Long, xTra As String
'
wArr = Range(Range("F1"), Range("F1").End(xlDown)).Value
For I = 1 To UBound(wArr)
    cWA = wArr(I, 1)
    If cWA > 139 Then xTra = "A" Else xTra = "B"
    wArr(I, 1) = xTra & Format(cWA, "000")
Next I
Range("F1").Resize(UBound(wArr), 1).Value = wArr
End Sub

Sub SSort(SKeys)
'
Dim RCnt As Long, CCnt As Long, I As Long, sOrd As Long
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    RCnt = Selection.Rows.Count
    CCnt = Selection.Columns.Count
    ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort.SortFields.Clear
    For I = 0 To UBound(SKeys)
    If SKeys(I) * 10 Mod 10 < 2 Then sOrd = 1 Else sOrd = 2
       
        ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort.SortFields.Add Key:=Cells(1, Int(SKeys(I))).Resize(RCnt, 1) _
            , SortOn:=xlSortOnValues, Order:=sOrd, DataOption:=xlSortNormal
    Next I
    With ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort
        .SetRange Range("A1").Resize(RCnt, CCnt)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With
End Sub


Codice: Seleziona tutto

‘CODICE AGGIUNTIVO PER LA RUOTA FINALE
Sub BNorm(Dummy)
'
Range(Range("H1"), Range("H1").End(xlDown)).Select
    Selection.Replace What:="Nazionale", Replacement:="ZZ", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False ', FormulaVersion:=xlReplaceFormula2  '**********************
End Sub

[Anthony47]

Selezionata un'area, all’interno della selezione, copiare la prima riga e incollare ad esempio in D10 copiare la seconda riga e incollarla ad esempio in C20 e così per le altre righe

Ad esempio:

Codice: Seleziona tutto

Dim OneLine As Range

For I = 1 To Selection.Rows.Count
    Application.WorksheetFunction.Index(Selection, I, 0).Copy Destination:=Range(Boh!)
Next I

Purtroppo la sequenza "D10" "C20" non mi offre spunti per capire quale e' la regola per scegliere dove incollare le righe (mi verrebbe voglia di continuare in B30, A40, ma poi?
Quindi se con questo ricco spunto non risolvi allora devi spiegare come va scelta la destinazione

Ciao

[ikwae]

Gentilissimo Anthony... quello che cerco non è dove incollare i dati ma l'indicazione di come scorrere le celle all'interno di una selezione

44 74 54 84 prendi questa riga e mettina dove ti pare o fare altro finito questo
78 84 11 58 prendi quest'altra riga e mettila dove ti pare o fare altro finito questo
40 54 84 11 prendi quest'altra riga e mettila dove ti pare o fare altro finito questo
76 15 85 29 prendi quest'altra riga e mettila dove ti pare o fare altro

a me interessa il "prendi questa riga". Ossia lo scorrimento all'interno della selezione.
Spero che sia più chiaro intanto provo la tua soluzione.Grazie cordialmente ikwae

[ikwae]

Gentilissimo Anthony …. Ho letto quello che ti ho scritto nel precedente post e c’è confusione con "prendi questa riga"
invece di “seleziona questa riga”. Forse così è spiegato meglio.

Codice: Seleziona tutto

44   74   54   84 1à)Selezione.Rows.Count.(Copy Destination:=Range(D10)
78   84   11   58 2à)Selezione.Rows.Count.(Copy Destination:= foglio “Pippo” Range(B1)
40   54   84   11 3à)Selezione.Rows.Count.(cancella il contenuto delle celle)
76   15   85   29 4à)Selezione.Rows.Count.(colora i numeri di rosso)
34   12   71   88 5à)Selezione.Rows.Count.(applica ai numeri il grassetto)


Se puoi scrivere due righe di codice, in questo semplice esempio indicativo, così io vedo le varie selezioni
(all’interno di un range selezionato) e, leggendo le righe del tuo codice, per capire il susseguirsi delle
selezioni così posso scrivere le mie macro casarecce. Grazie ancora di tutto cordialmente ikwae

[Anthony47]

Sarò "de coccio" ma ancora non ho capito quel che scrivi; quindi vado avanti con qualche esercizio che mi invento io:
1) Data un intervallo di celle, mettere in grassetto una cella per riga, cominciando dalla colonna piu' a sinistra e spostandosi in diagonale; raggiunta l'ultima colonna si ricomincia con la prima.
Svolgimento:

Codice: Seleziona tutto

Sub ScalArea()
Dim I As Long, nCols As Long, J As Long, myArea As String
'
myArea = "B2:F20"    '<<< L'intervallo
nCols = Range(myArea).Columns.Count
Range(myArea).Font.Bold = False
For I = 1 To Range(myArea).Rows.Count
    J = I Mod nCols + 1
    Range(myArea).Cells(1, 1).Offset(I - 1, J - 1).Font.Bold = True
Next I
End Sub


Se vuoi che l'intervallo sia quello "Selezionato", ti bastera' sostituire le varie Range(myArea).xx con Selection.xx
Il risultato sara':



2) Dato un intervallo di celle, colorare le righe pari in verde e quelle dispari in giallo
Svolgimento:

Codice: Seleziona tutto

Sub ColorArea()
Dim I As Long, nCols As Long, J As Long, myArea As String
'
myArea = "B2:F20"
Range(myArea).Interior.Color = xlNone
For I = 1 To Range(myArea).Rows.Count
    J = I Mod 2
    If J = 0 Then
        Application.WorksheetFunction.Index(Range(myArea), I, 0).Interior.Color = RGB(0, 255, 0)   'Verde
    Else
        Application.WorksheetFunction.Index(Range(myArea), I, 0).Interior.Color = RGB(255, 255, 0) 'Giallo
    End If
Next I
End Sub

Ovviamente sarebbe anche possibile usare, invece del ciclo If J =0 Then /Else /End if la sola

Codice: Seleziona tutto

    Application.WorksheetFunction.Index(Range(myArea), I, 0).Interior.Color = RGB(255 * J, 255, 0) 'Giallo /Verde

Il risultato sara':



3) Ultimo esempio
Dato un intervallo di celle, suddividerlo in blocchi di 4 righe:
-copiare la prima riga nella colonna adiacente
-copiare la seconda riga su Foglio1, a partire da colonna A, la prima riga libera
-applicare il grassetto alla terza riga
-colorare di rosso la quarta riga
Svolgimento:

Codice: Seleziona tutto

Sub BlockArea()
Dim I As Long, RowNum As Long, J As Long, myArea As String
Dim nCols As Long, F1Next As Long
'
myArea = "B2:F20"
nCols = Range(myArea).Columns.Count
'Reset iniziale:
Range(myArea).Interior.Color = xlNone
Range(myArea).Font.Color = RGB(0, 0, 0)
Range(myArea).Font.Bold = False
RowNum = Range(myArea).Rows.Count
For I = 1 To RowNum Step 4
    Application.WorksheetFunction.Index(Range(myArea), I, 0).Copy Destination:=Range(myArea).Cells(I, nCols + 1)
    F1Next = Sheets("Foglio1").Cells(Rows.Count, 1).End(xlUp).Row + 1
    If I < RowNum Then Application.WorksheetFunction.Index(Range(myArea), I + 1, 0).Copy Destination:=Sheets("foglio1").Cells(F1Next, 1)
    If (I + 1) < RowNum Then Application.WorksheetFunction.Index(Range(myArea), I + 2, 0).Font.Bold = True
    If (I + 2) < RowNum Then Application.WorksheetFunction.Index(Range(myArea), I + 3, 0).Font.Color = RGB(255, 0, 0)
Next I
End Sub

Il risultato sara':


Le righe indicate con << sono state "accodate" su Foglio1

Anche nel secondo e terzo caso vale lo stesso discorso a proposito della sostituzione di Range(myArea).xx con Selection.xx

Sono "esempi", e ovviamente gli stessi risultati potrebbero essere ottenuti in 27 modi diversi; noterai che non c'e' nessun ".Select", perche' raramente e' utile e quasi mai e' necessario farlo. Lo facessi allora dovrei come minimo raddoppiare il numero di righe di codice. Tipo, invece di If I < RowNum Then Application.WorksheetFunction.Index(Range(myArea), I + 1, 0).Copy Destination:=Sheets("foglio1").Cells(F1Next, 1)

Codice: Seleziona tutto

    If I < RowNum Then
        Application.WorksheetFunction.Index(Range(myArea), I + 1, 0).Select
        Selection.Copy Destination:=Sheets("foglio1").Cells(F1Next, 1)
    End If


Le macro autoregistrate sono invece zeppe di ".select" semplicemente perche' il registratore di macro non ci legge nel pensiero; producono codice disottimizzato ma comunque funzionante.

Spero che trovi qualcosa che ti ispiri.

Ciao

[ikwae]

Gentilissimo Anthony ….

Sarò "de coccio" ma ancora non ho capito quel che scrivi; quindi vado avanti con qualche esercizio che mi invento io:

Te che hai tanti anni di esperienza e dato soluzioni in tutti questi anni non puoi affremare quello che hai scritto. Sono io che mi spiego male ho riletto i post che scrivo ma rimango confuso anch’io che conosco Il procedimento (difatti l’ho modificato tre volte) figurati chi legge per aiutarmi.

Solitamente prima si provano le soluzioni proposte e poi si scrive il riscontro ma dato che ho visto che le soluzioni proposte
sono molteplici e impiegherei tanto tempo a tastarle tutte e di conseguenza darei un responso con molto ritardo si potrebbe
interpretare negativamente. Aggiungo che scrivendo prima il post posso dare una spiegazione di cosa voglio che penso fino
adeso non sono riuscito a dare.

Quindi a me serve un ciclo che seleziona ogni riga dell’intervallo selezionato. Solo ed esclusivamente all’interno di una selezione.
Ti faccio un esempio concreto. Da anni ormai uso un preciso intervallo sempre lo stesso. Una volta portati i dati in quest’intervallo si esegue una macro che inizia a copiare la prima riga e la incolla in una colonna di un Archivio orizzontale poi copia la seconda riga e la incolla in un’altra colonna dell’Archivio orizzontale e così per tutte le righe finita la macro ne chiama un’altra macro la quale seleziona la prima riga e la confronta con il pronostico fatto in precedenza e se ci sono esiti positivi colora le celle di giallo per un ambo,i numeri in blu se ci sono terni mentre per le quaterne colora i numeri in viola. Continua selezionando la seconda riga e la confronta con il pronostico e se ci sono esiti positivi fa lo stesso di prima così fino all’ultima riga. Finita la macro dei confronti ne richiama un’altra che copia tutto l’intervallo, comprese le celle colorate, incollando in un Archivio verticale poi richiama un’altra macro ecc. ecc.

Quindi si lavora in un preciso intervallo che io vorrei SOSTITUIRE (per evidenziare non per urlare) con un intervallo “anonimo” ossia selezionando delle celle e all’interno di questa selezione devo fare tutte le operazioni[. Conoscendo il ciclo che seleziona le varie righe posso modificare tutte le mie macro casarecce da un intervallo sempre lo stesso ad una selezione anonima.

Poi con l’arrivo del “segugiamento” al terno con particolare attenzione alla quaterna (rammento che ne serve solo uno).
Vorrei creare ULTERIORI (per evidenziare non per urlare) macro che lavorano esclusivamente all’interno di una selezione dove si mandano in esecuzioni delle macro per eseguire le dovute necessità riguardo al “segugiamento” del terno.

Pertanto a conoscenza di quanto scritto su chiedo, dato che te conosci alla lettera le tue soluzioni del post sopra, che farai prima di me, che le devo provare tutte, capire se posso trovare qualche cosa da utilizzare in concreto oppure hai qualche altra indicazione da darmi.

Io da parte mia leggerò con molta attenzione e proverò tutte le tue indicazioni al fine di trovare qualche cosa di utile come sopra riportato. Se non troverò elementi congrue saranno sicuramente utili per altri lavori, specialmente codici scritti da te (qui non si spreca nessuna riga di codice) eventualmente posterò, se necessario, il dovuto riscontro.

Cordialmente ikwae

[Anthony47]

Ti faccio un esempio concreto. Da anni ormai uso un preciso intervallo sempre lo stesso. Una volta portati i dati in quest’intervallo si esegue una macro che inizia a copiare la prima riga e la incolla in una colonna di un Archivio orizzontale poi copia la seconda riga e la incolla in un’altra colonna dell’Archivio orizzontale e così per tutte le righe

Una macro e' una sequenza di istruzioni che produce un risultato predeterminato dal codice.
Ora mi e' chiaro che stai cercando una macro che selezioni una riga dopo l'altra di una selezione (probabilmente multicolonna), ma non ti posso dare una macro che copi "prima qua e poi là" se non posso determinare tramite codice dove e' Qua e dove e' Là.

Torno quindi a quanto avevo scritto il 28-5 pomeriggio e poi utilizzato anche negli esempi 2 e 3 del messaggio del 29-5 pomeriggo; e cioe' (adattandolo al concetto di Selection):

Codice: Seleziona tutto

For I = 1 To Selection.Rows.Count
    Application.WorksheetFunction.Index(Selection, I, 0)…….
Next I


I indica quale riga della Selezione va prelevato
La parte Application.WorksheetFunction.Index(Selection, I, 0) punta alla "riga I" dell'area selezionata; a questo intervallo puoi ora applicare un "metodo" o una "proprietà" per ottenere quel che serve. Se vuoi "copiare" l'intervallo allora userai

Codice: Seleziona tutto

Application.WorksheetFunction.Index(Selection, I, 0).Copy

Il "prima qua e poi là" invece non si puo' codificare, quindi dopo la ".Copy" non so cosa metterci.
Supponiamo quindi che tu non voglia copiare "prima qua e poi là", ma (lo invento io per completare l'esempio) nella prima riga dell'area selezionata, dalla prima colonna libera e procedendo verso destra.
Questa regola puo' essere quindi tradotta in questa macro:

Codice: Seleziona tutto

Sub CopiaTuttoSuPrimaRiga()
Dim I As Long, nCols As Long
'
nCols = Selection.Columns.Count
For I = 1 To Selection.Rows.Count
'Copia la singola Riga, Incolla a destra di riga1 della Selezione:
    Application.WorksheetFunction.Index(Selection, I, 0).Copy Destination:=Selection.Cells(1, 1).Offset(0, I * nCols)
Next I
End Sub


Spero sia traducibile a quello che hai in testa...

[ikwae]

Gentilissimo Anthony … ho aperto il post per dare il responso come avevo detto e ho apppena visto il tuo post intanto che lo leggo e faccio le prove del tuo post appena scritto prova a dare un'occhiata al mio forse ho risolto!!
'-----------
Dal tuo esempio n°3 l’ho “sezionato” creando 4 righe di codice distinte e, per ogni riga, ho scritto 4 cicli ossia 4 macro distinte per genere.Quindi ho creato il mio ciclo all’interno di una selezione . Replicando per 11 volte la stessa istruzione (modificato solo dove serve) ma solo le prime due repliche non esce l’errore da tre repliche in su esce sempre l’errore giallo sempre all’ultima replica con 11 repliche esce errore alla 11 con 8 repliche esce errore all’ottava replica con 5 esce l’errore alla 5 sempre all’ultima.
Se mi dici dove sbaglio eppure sembra che i numeri li mette bene al proprio posto in colonna completando il ciclo precedentemente selezionato sulle celle.

In ultimo un chiarimento riguardo

Codice: Seleziona tutto

If I < RowNum Then

(se il numero (I) è minore delle celle selezionate procedi) ma io, per prova, seleziono molte di più righe che servono e va lo stesso anche se dove incolla sul foglio Pippo ci sono copiati righe in più (che sono errate ovviamente). Se puoi darmi una indicazione al riguardo.
Allego al post solo tre repliche per capire cosa ho fatto (e se ho fatto bene) e perché esce l’errore Cordialmente ikwae

Codice: Seleziona tutto

‘ERRORE TUTTO GIALLO SEMPRE SULL’ULTIMA REPLICA
  Application.WorksheetFunction.Index(Selection, I + 2, 0).Copy _
    Destinati on:=Sheets("Pippo").Cells(fiF1Next, 15)

Codice: Seleziona tutto

Sub BlockArea_Ciclo_Concorso()
Dim I As Long, RowNum As Long
Dim nCols As Long, baF1Next As Long, caF1Next As Long, fiF1Next As Long

 nCols = Selection.Columns.Count
 RowNum = Selection.Rows.Count

 For I = 1 To RowNum 'Step 4
       
  'BA_Col 03 la C
    baF1Next = Sheets("Pippo").Cells(Rows.Count, 3).End(xlUp).Row + 1
       If I < RowNum Then Application.WorksheetFunction.Index(Selection, I + 0, 0).Copy _
    Destination:=Sheets("Pippo").Cells(baF1Next, 3)
   
  'CA_Col 09 la I
    caF1Next = Sheets("Pippo").Cells(Rows.Count, 9).End(xlUp).Row + 1
       If I < RowNum Then Application.WorksheetFunction.Index(Selection, I + 1, 0).Copy _
    Destination:=Sheets("Pippo").Cells(caF1Next, 9)

  'FI_Col 15 la O
    fiF1Next = Sheets("Pippo").Cells(Rows.Count, 15).End(xlUp).Row + 1
       If I < RowNum Then Application.WorksheetFunction.Index(Selection, I + 2, 0).Copy _
    Destination:=Sheets("Pippo").Cells(fiF1Next, 15)

Next I
End Sub

[Anthony47]

L'uso di If I<RowNum serve a evitare che la successiva istruzione Application.WorksheetFunction.Index punti a una riga che sia superiore a quelle presenti nell'area selezionata; ed e' questa situazione che, penso, generi gli errori di cui tu parli.
Se guardi il mio "esempio 3" noterai

Codice: Seleziona tutto

    If I < RowNum Then Application.WorksheetFunction.Index(Range(myArea), I + 1, 0)....
    If (I + 1) < RowNum Then Application.WorksheetFunction.Index(Range(myArea), I + 2, 0).....
    If (I + 2) < RowNum Then Application.WorksheetFunction.Index(Range(myArea), I + 3, 0)....

Se lo confronti col tuo codice noterai

Codice: Seleziona tutto

       If I < RowNum Then Application.WorksheetFunction.Index(Selection, I + 0, 0).....
.....
       If I < RowNum Then Application.WorksheetFunction.Index(Selection, I + 1, 0).....
.....
       If I < RowNum Then Application.WorksheetFunction.Index(Selection, I + 2, 0).....

In altre parole, tu non eviti di puntare a una riga inesistente, perche' controlli che I<RowNum ma poi come indice usi I+1 (confronto sufficiente) e I+2 (controllo invece insufficiente).
Aggiungo che il controllo If I < RowNum sulla riga che usa "I +0" e' dannoso, perche' impedisce che l'ultima riga (quando I sara' uguale a RowNum) venga copiata in colonna C.

Se con queste considerazioni non risolvi allora pubblica il tuo file dimostrativo e vedremo.

Ciao

[ikwae]

Gentilissimo Anthony… Innanzitutto grazie per aver messo a posto il mio post che non so come sia successo
di andare a postare in un altro post eppure non me lo spiego. Tuttavia è successo grazie ancora …
********************
Ho letto e riletto il tuto ultimo post di aiuto e ho configurato il tutto aggiungendo, quello che ho capito, ma va oltre
ossia copia diverse volte in più le stesse righe a “scalare” sulle colonne.

Ti allego un file con dentro due fogli uno per selezionare e, l'altro, il foglio Pippo (che sarebbe l’archivio orizzontale)
dove scrive i dati. Devi solamente selezionare l’area e cliccare sul diamante e sul foglio Pippo i disastrosi risultati. Vedi se riesci a capire i disastri nella configurazione della macro che ho realizzato eppure a me sembra che abbia fatto tutto a “norma”.
Sta diventando un lavoro altro che hobby. Cordialmente ikwae

Il codice che ho adottato:

Codice: Seleziona tutto

Sub BlockArea_Ciclo_Concorso()
Dim I As Long, RowNum As Long
Dim nCols As Long
Dim baF1Next As Long, caF1Next As Long, fiF1Next As Long, geF1Next As Long
Dim miF1Next As Long, naF1Next As Long, paF1Next As Long, rmF1Next As Long
Dim toF1Next As Long, veF1Next As Long, rnF1Next As Long
  '
   nCols = Selection.Columns.Count
   RowNum = Selection.Rows.Count
 
 For I = 1 To Selection.Columns.Count

'BA_Col 03 la C
   baF1Next = Sheets("Pippo").Cells(Rows.Count, 3).End(xlUp).Row + 1
             If I < RowNum Then Application.WorksheetFunction.Index(Selection, I + 1, 0).Copy _
   Destination:=Sheets("Pippo").Cells(baF1Next, 3)
   
'CA_Col 09 la I
    caF1Next = Sheets("Pippo").Cells(Rows.Count, 9).End(xlUp).Row + 1
        If (I + 1) < RowNum Then Application.WorksheetFunction.Index(Selection, I + 2, 0).Copy _
     Destination:=Sheets("Pippo").Cells(caF1Next, 9)

'FI_Col 15 la O
    fiF1Next = Sheets("Pippo").Cells(Rows.Count, 15).End(xlUp).Row + 1
        If (I + 2) < RowNum Then Application.WorksheetFunction.Index(Selection, I + 3, 0).Copy _
    Destination:=Sheets("Pippo").Cells(fiF1Next, 15)

'GE_Col 21 la U
    F1Next = Sheets("Pippo").Cells(Rows.Count, 21).End(xlUp).Row + 1
        If (I + 3) < RowNum Then Application.WorksheetFunction.Index(Selection, I + 4, 0).Copy _
    Destination:=Sheets("Pippo").Cells(F1Next, 21)

'MI_Col 27 la AA
    F1Next = Sheets("Pippo").Cells(Rows.Count, 27).End(xlUp).Row + 1
         If (I + 4) < RowNum Then Application.WorksheetFunction.Index(Selection, I + 5, 0).Copy _
    Destination:=Sheets("Pippo").Cells(F1Next, 27)
 
'NA_Col 33 la AG
    F1Next = Sheets("Pippo").Cells(Rows.Count, 33).End(xlUp).Row + 1
         If (I + 5) < RowNum Then Application.WorksheetFunction.Index(Selection, I + 6, 0).Copy _
    Destination:=Sheets("Pippo").Cells(F1Next, 33)
 
'PA_Col 39 la AM
    F1Next = Sheets("Pippo").Cells(Rows.Count, 39).End(xlUp).Row + 1
          If (I + 6) < RowNum Then Application.WorksheetFunction.Index(Selection, I + 7, 0).Copy _
    Destination:=Sheets("Pippo").Cells(F1Next, 39)
   
'RM_Col 45 la AS
    F1Next = Sheets("Pippo").Cells(Rows.Count, 45).End(xlUp).Row + 1
          If (I + 7) < RowNum Then Application.WorksheetFunction.Index(Selection, I + 8, 0).Copy _
    Destination:=Sheets("Pippo").Cells(F1Next, 45)
 
'TO_Col 51 la AY
    F1Next = Sheets("Pippo").Cells(Rows.Count, 51).End(xlUp).Row + 1
          If (I + 8) < RowNum Then Application.WorksheetFunction.Index(Selection, I + 9, 0).Copy _
    Destination:=Sheets("Pippo").Cells(F1Next, 51)
 
'VE_Col 57 la BE
    F1Next = Sheets("Pippo").Cells(Rows.Count, 57).End(xlUp).Row + 1
          If (I + 9) < RowNum Then Application.WorksheetFunction.Index(Selection, I + 10, 0).Copy _
    Destination:=Sheets("Pippo").Cells(F1Next, 57)
   
'RN_Col 63 la BK
    F1Next = Sheets("Pippo").Cells(Rows.Count, 63).End(xlUp).Row + 1
         If (I + 10) < RowNum Then Application.WorksheetFunction.Index(Selection, I + 11, 0).Copy _
    Destination:=Sheets("Pippo").Cells(F1Next, 63)
Next I
End Sub

[ikwae]

Chiedo scusa mi ero dimenticato di allegare il file...
http://www.filedropper.com/selezioneareaconcorsorete

[Anthony47]

Una macro che fa quel che dici e' questa:

Codice: Seleziona tutto

Sub BlockArea_Ciclo_Concorso()
Dim I As Long, RowNum As Long
Dim nCols As Long
Dim baF1Next As Long
  '
   nCols = Selection.Columns.Count
'   RowNum = Selection.Rows.Count
 
baF1Next = Sheets("Pippo").Cells(Rows.Count, 3).End(xlUp).Row + 1
For I = 1 To Selection.Rows.Count
    Application.WorksheetFunction.Index(Selection, I, 0).Copy _
      Destination:=Sheets("Pippo").Cells(baF1Next, 3 + (I - 1) * (nCols + 1))
Next I
End Sub

La logica: data una selezione di Y righe e X colonne, trasporre in orizzontale la matrice sulla prima riga libera di colonna C.
Pertanto: calcolo 1 sola volta la riga di destinazione; poi con Application.WorksheetFunction.Index determino la riga da posizionare e con Destination:=Sheets("Pippo").Cells(baF1Next, 3 + (I - 1) * (nCols + 1)) determino il suo posizionamento.

Ciao

[ikwae]

Gentilissimo Anthony... Ho provato la tua macro e funge al 100% mettendo tutto in ordine sul foglio Pippo....
Dopo una settimana di dai e dai finalemnte passo ai ringraziamnti dicendoti che dopodomani aprono le "Frontiere Regionali" ...
Ringraziandoti mille e mille volte per il tuo aiuto cordilmente ikwae