RIEPILOGARE DATI DA PIU FOGLI

Hai un problema con Excel?

Nuova discussione

RIEPILOGARE DATI DA PIU FOGLI
di alexpag (utente non iscritto) data: 10/03/2015 14:23:31
Salve vi spiego il mio problema:
Ho una scheda ordini ( preimpostata) che compilo con i vari ordini dei clienti e dopo aver inserito tutti gli ordini ( un foglio per ciascun cliente) li ricopio tutti manualmente in un foglio riepilogo.
Vorrei automatizzare questa fase cioè ricopiare nel riepilogo tutti i dati di cascun foglio ( ordine) presente.
Dopo averli copiati nel riepilogo li devo ordinare ( cosa che faccio manualmente ) per codice,mutanda,tessuto,colore ecc.
Una volta ordinati come detto vorrei accorpare i totali per ciscun codice, mutanda,tessuto,colore.
Spero di essere stato chiaro
Allego il file che uso
di Lucas87 data: 10/03/2015 15:08:43
Ciao
Riportare i valori di più fogli su uno di riepilogo è la richiesta più gettonata. Prova a guardare tra le vecchie discussioni, troverai quello che serve.
Per ordinarli puoi provare a usare il registratore di macro in modo da ottenere un codice che fa al caso tuo.
Se non ti è chiaro chiedi...
di alexpag (utente non iscritto) data: 10/03/2015 19:22:26
Ehm.....ho cercato in tutti i forum ma non sono riuscito a combinare nulla....sicuramente perchè non capisco niente di VBA....
potreste aiutarmi?

di Lucas87 data: 11/03/2015 08:27:27
Prova questo.
Si presuppone che i fogli da cui leggere vadano dal secondo in poi e che l'ultimo sia il foglio di riepilogo.
I valori sono ordinati secondo il codice (colonna B)

Sub riepilogo()
Application.ScreenUpdating = False
r = Sheets("riepilogo ordinato").Range("b" & Rows.Count).End(xlUp).Row
For i = 2 To Sheets.Count - 1
    k = Sheets(i).Range("b2").End(xlDown).Row
    Sheets("riepilogo ordinato").Range("a" & r + 1 & ":y" & r + k - 1) = Sheets(i).Range("a2:y" & k).Value
    r = r + k - 1
Next
Range("a2:y" & r).Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlNo
Application.ScreenUpdating = True
End Sub

di alexpag (utente non iscritto) data: 11/03/2015 11:16:01
Ciao Luca grazie per la risposta....c'è qualche problema.....mi duplica i dati 2 volte nel riepilogo ordinati..... e non mi accorpa sommando i codici uguali con lo stesso tessuto e colore....
di Lucas87 data: 11/03/2015 11:51:06
Hai tolto il foglio riepilogo? Non credo
Mi sono dimenticato della parte di accorpamento...provvedo.

di Lucas87 data: 11/03/2015 12:05:04
Sostituisci il codice

Application.ScreenUpdating = False
r = Sheets("riepilogo ordinato").Range("b" & Rows.Count).End(xlUp).Row
For i = 2 To Sheets.Count - 1
    k = Sheets(i).Range("b2").End(xlDown).Row
    Sheets("riepilogo ordinato").Range("a" & r + 1 & ":y" & r + k - 1) = Sheets(i).Range("a2:y" & k).Value
    r = r + k - 1
Next
Range("a2:y" & r).Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlNo
For i = r To 2 Step -1
    If Cells(i, 2) = Cells(i - 1, 2) And Cells(i, 5) = Cells(i - 1, 5) And Cells(i, 7) = Cells(i - 1, 7) And Cells(i, 8) = Cells(i - 1, 8) Then
         arr = Array(Cells(i, 11), Cells(i, 12), Cells(i, 13), Cells(i, 14), Cells(i, 15), Cells(i, 16), Cells(i, 17), Cells(i, 18), Cells(i, 19), Cells(i, 20), Cells(i, 21), Cells(i, 23), Cells(i, 24))
        For Each ce In arr
            If ce <> "" Then
                ce.Offset(-1, 0) = ce.Offset(-1, 0) + ce.Value
            End If
        Next
        Rows(i).Delete
    End If
Next
Application.ScreenUpdating = True

di alexpag (utente non iscritto) data: 11/03/2015 12:28:31
Ciao Luca.....certo che ho tolto il foglio riepilogo....( almeno al secondo tentativo...)
anche la seconda macro mi duplica i valori.
cerco di spiegarmi.....praticamente dovrebbe venire come nel foglio riepilogo ordinato fatto manualmente.
di Lucas87 data: 11/03/2015 12:49:59
Non so cosa dirti a me funziona.
Il risultato è uguale a quello del file allegato da te. Poi accorpando i dati vengono tolte 6 righe.
I fogli presenti devono essere
NUOVO,marco,alex,michele,...tutti gli altri...,riepilogo ordinato
di alexpag77 (utente non iscritto) data: 11/03/2015 13:29:58
Ehm.....Luca avevi ragio....avevo lasciato l'ultimo foglio ( codici accorpati)..... adesso funziona.....sei miticooooooooo....grazie milleee.......
di alexpag (utente non iscritto) data: 11/03/2015 13:33:40
Scausa Luca un ultima cosa....nel caso in cui non voglio accorpare i modelli con stessi tessuti e colori quali parti del codice devo eliminare?
di alexpag (utente non iscritto) data: 11/03/2015 13:52:12
scusami Luca.....approfitto della tua disponibilità.....ho visto che mi mi accorpa con stessi codici,tessuto e colori....si può aggiungere anche se sono uguali contrasto e note ?? ( altrimenti mi spariscono nel riepilogo)
e come ti chiedevo prima, nel caso in cui non vorrei accorpare nulla ( magari lo faccio manualmente) quale parte del codice vba devo eliminare?
grazie mille e scusa ancora il disturbo

di Lucas87 data: 11/03/2015 14:02:52
La parte che accorpa è quella sotto
Quella che controlla quali righe accorpare è questa

If Cells(i, 2) = Cells(i - 1, 2) And Cells(i, 5) = Cells(i - 1, 5) And Cells(i, 7) = Cells(i - 1, 7) And Cells(i, 8) = Cells(i - 1, 8) Then

cioè, presa una, riga verifica che siano uguali i valori delle colonne B, E, G, H nella riga precedente.
Contrasto e note sono sulle colonne I e J...prova tu ad aggiungerle.

For i = r To 2 Step -1
    If Cells(i, 2) = Cells(i - 1, 2) And Cells(i, 5) = Cells(i - 1, 5) And Cells(i, 7) = Cells(i - 1, 7) And Cells(i, 8) = Cells(i - 1, 8) Then
         arr = Array(Cells(i, 11), Cells(i, 12), Cells(i, 13), Cells(i, 14), Cells(i, 15), Cells(i, 16), Cells(i, 17), Cells(i, 18), Cells(i, 19), Cells(i, 20), Cells(i, 21), Cells(i, 23), Cells(i, 24))
        For Each ce In arr
            If ce <> "" Then
                ce.Offset(-1, 0) = ce.Offset(-1, 0) + ce.Value
            End If
        Next
        Rows(i).Delete
    End If
Next

di alexpag (utente non iscritto) data: 11/03/2015 19:58:35
sei un mito Luca....grazie mille.....spero di aver capito come aggiungere le due colonne.....ti allego il codice......invece per togliere l'accorpamento copio il primo codice che mi avevi postato....
Grazie ancora e complimenti per la bravura

Sub riepilogoaccorpa()
Application.ScreenUpdating = False
r = Sheets("riepilogo ordinato").Range("b" & Rows.Count).End(xlUp).Row
For i = 2 To Sheets.Count - 1
    k = Sheets(i).Range("b2").End(xlDown).Row
    Sheets("riepilogo ordinato").Range("a" & r + 1 & ":y" & r + k - 1) = Sheets(i).Range("a2:y" & k).Value
    r = r + k - 1
Next
Range("a2:y" & r).Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlNo
For i = r To 2 Step -1
    If Cells(i, 2) = Cells(i - 1, 2) And Cells(i, 5) = Cells(i - 1, 5) And Cells(i, 7) = Cells(i - 1, 7) And Cells(i, 8) = Cells(i - 1, 8) And Cells(i, 9) = Cells(i - 1, 9) And Cells(i, 10) = Cells(i - 1, 10) Then
         arr = Array(Cells(i, 11), Cells(i, 12), Cells(i, 13), Cells(i, 14), Cells(i, 15), Cells(i, 16), Cells(i, 17), Cells(i, 18), Cells(i, 19), Cells(i, 20), Cells(i, 21), Cells(i, 23), Cells(i, 24))
        For Each ce In arr
            If ce <> "" Then
                ce.Offset(-1, 0) = ce.Offset(-1, 0) + ce.Value
            End If
        Next
        Rows(i).Delete
    End If
Next
Application.ScreenUpdating = True
End Sub

Vuoi Approfondire?