Piano taglie in verticale

[Making]

Ciao vorrei un vostro consiglio per creare a macro che trasforma un database dove la taglia è in riga e non in colonna. La tipologiia della taglia è indicata nella colonna Q (ci sono 6 tipi) mentre la scala si trova nel range R- AG (vedi immagine).

https://ibb.co/TrXyf7K

Help!
grazie

[Making]

Allego seconda immagine per spiegare meglio cosa vorrei ottenere (il file originale è più lungo).

https://ibb.co/VSdrmkT

[Anthony47]

Meglio se alleghi un file su cui lavorare...
Poi non mi e' chiaro come i campi del formato di origine si dovrebbero mappare sul formato di uscita, quindi sarebbe meglio che lo descrivi invece che farcelo indovinare (e io come indovino sono scarso).

Per le istruzioni su come allegare un file:
viewtopic.php?f=26&t=103893&p=605487#p605487

Ciao

[Making]

Eccolo, fatemi sapere, grazie.

http://www.filedropper.com/helptaglie_2

[Anthony47]

Hai lasciato a me indovinare le informazioni da mappare...

Prova la seguente macro:

Codice: Seleziona tutto

Sub Rimappa()
Dim arrFrom, arrTo, I As Long, myC As Range, J As Long
Dim hvCol As String, dePos As Range, KR As Long, K As Long
'
arrFrom = Array("A:P", "AH:AL")             '<<< Aree da copiare
arrTo = Array("A", "Q")                     '<<< ... e incollare in quest'altra posizione
hvCol = "R:AG"                              '<<< Colonne da "mettere in verticale"
Set dePos = Sheets("Foglio1").Range("A2")   '<<< Foglio e area su cui creare il nuovo elenco
KR = 9                                      '<<< Riga iniziale di dati
'
Sheets("magazzino").Select
Do
If Application.WorksheetFunction.CountA(Application.Intersect(Range(arrFrom(0)), Rows(KR + K))) = 0 Then Exit Do
    For Each myC In Application.Intersect(Range(hvCol), Rows(KR + K))
        If myC.Value <> "" Then
            dePos.Offset(J, 21) = Cells(4, myC.Column).Value
            For I = 0 To UBound(arrFrom)
                Application.Intersect(Range(arrFrom(I)), Rows(KR + K)).Copy dePos.Offset(J, Range(arrTo(I) & "1").Column - 1)
            Next I
            J = J + 1
        End If
    Next myC
    K = K + 1
Loop
MsgBox ("Remapping completato...")
End Sub


In testa (vedi righe marcate <<<) le cose che mi sono immaginate io; adatta se non ho indovinato.

La macro compila un nuovo elenco sul foglio /range descritto; le intestazioni immagino siano fisse quindi le puoi inserire a mano sull'area di destinazione una volta per tutte

Fai sapere...

[Making]

Grazie, ho provato a lanciarlo. vedi in allegato il risultato: ho indicato a lato delle colonne il risultato atteso (vedi in giallo).

1/ Le quantità devono essere "splittate" in funzione delle quantità disponibili per taglia
2/ idem per il valore
3/ Le scala taglie sono 6 (vedi celle da Q3 a Q8). In funzione di quanto riportato nella colonna "Q", viene abilitata la corrispondente scala taglia. Ad esempio in Q9 c'è la "B" quindi la scala taglia va dalla 38 fino alla 60, l'unico pezzo è nella taglia 44. in Q10 c'è la "C" quindi si va dalla XXS a XXXL.

http://www.filedropper.com/prova_1

[Anthony47]

Hai lasciato a me indovinare le informazioni da mappare...

Te l'avevo detto che come indovino sono scarso
E ti potevi anche impegnare a scrivere in Foglio1 le intestazioni di colonna così non dovevo anche stavolta indovinarmele da me e indovinare cosa hai aggiunto e dove e indovinare perche'...

Comunque prova con:

Codice: Seleziona tutto

Sub Rimappa2()
Dim arrFrom, arrTo, I As Long, myC As Range, J As Long
Dim hvCol As String, dePos As Range, KR As Long, K As Long
Dim Taglie, tRange As Range
'
arrFrom = Array("A:O", "AH:AL")             '<<< Aree da copiare
arrTo = Array("A", "S")                     '<<< ... e incollare in quest'altra posizione
hvCol = "R:AG"                              '<<< Colonne da "mettere in verticale"
Set dePos = Sheets("Foglio1").Range("A8")   '<<< Foglio e area su cui creare il nuovo elenco
KR = 9                                      '<<< Riga iniziale di dati
Taglie = Array("B", "C", "5", "3", "Y", "9")    '<<< Le possibili taglie
Set tRange = Sheets("magazzino").Range("R3")    '<<< L'inizio del tabellone taglie
'
Sheets("magazzino").Select
Do
If Application.WorksheetFunction.CountA(Application.Intersect(Range(arrFrom(0)), Rows(KR + K))) = 0 Then Exit Do
    For Each myC In Application.Intersect(Range(hvCol), Rows(KR + K))
        If myC.Value <> "" Then
            toff = Application.Match(Cells(KR + K, "Q").Value, Taglie, False)
            If Not IsError(toff) Then
                For I = 0 To UBound(arrFrom)
                    Application.Intersect(Range(arrFrom(I)), Rows(KR + K)).Copy dePos.Offset(J, Range(arrTo(I) & "1").Column - 1)
                Next I
                dePos.Offset(J, 15) = tRange.Cells(toff, myC.Column - 17)
                dePos.Offset(J, 16) = myC.Value
                dePos.Offset(J, 17) = dePos.Offset(J, 14).Value * myC.Value
            End If
            J = J + 1
        End If
    Next myC
    K = K + 1
Loop
MsgBox ("Remapping completato...")
End Sub


Le colonne A:O ricopiano quelle di partenza; poi ci sono 3 colonne con contenuti "calcolati"; da colonna S in avanti riprende le colonne AH:AL di partenza.

Ciao

[Making]

Grazie, funziona solo che su file molto grossi si pianta, perchè?

[Anthony47]

Mi fai un esempio di "file molto grosso"?

[Making]

Quello sul quale devo lavorare sono 76000 righe ...

[Anthony47]

Appena mi avanza del tempo andro' a rileggere i messaggi precedenti per capire che cosa significa e crearmi poi un file di prova. Appena...