-
Articoli
-
Buona sera, sono sempre alle prese e sviluppo di un file per fare un computo metrico,
e mi ritrovo a scrivere di nuovo,
sono al punto di aver creato una macro che sul foglio SAL N° 1 ho una lista di lavorazioni, le ho inserite in modo sconclusionato, sia nell'ordine della WBS(Colonna "G") che negli articoli, (colonna "J"), questa cosa
l'ho fatto di proposito e volutamente.
Attualmente la macro raggruppa le lavorazioni per Articolo, e inserisce una riga di subTotale, con la formattazione sia nel colore che nel Font.
ma ora vengo al dunque, e chiedo il vostro aiuto.
Mi servirebbe che il raggruppamento avvenisse prima per WBS e poi per articolo.
mi spiego meglio, al cliccare del tasto da me creato, la lista delle lavorazioni devono raggrupparsi e mettersi in ordine per WBS, (Quindi un Sub Totale per WBS), ed allo stesso tempo tempo deve creare nel gruppo WBS i Sub_Totali per Articoli.
per le vie brevi deve esserci Sub_Totali per articolo e Sub_Totale WSB che raggruppa poi i Sub_Totali articoli.
questa cosa la riesco a fare con la PIVOT, ma mi servirebbe per rendere il mio file gestito tutto tramite macro e automatizzato.
prima di aiutarmi vi chiedo di dare un occhio al mio file che allego, cliccate sul tasto "Subtotali Art.",
chiedo gentilmente se riuscite ad aiutarmi.
Ti posto questo codice che è da adattare alle tue esigenze. Nel file che hai allegato, in serisci un foglio nuovo dopo il foglio "SALN°1", è lo rinomini "Vuoto",poi inserisci il codice che ti posto in un modulo VBA e lo esegui, naturalmente lo devi affinare per le tue esigenze.
Ciao
Sub Albatros54ComputoMetrico() Dim Ag As New Collection Dim Rw As Long Dim LR As Long Dim Sh As String Dim wsChk As Worksheet On Error Resume Next Application.ScreenUpdating = False Application.DisplayAlerts = True With Sheets("SAL N°1") Rw = .Cells(Rows.Count, 7).End(xlUp).Row Set Rng = Range(.Cells(7, 7), .Cells(Rw, 7)) For Each cel In Rng If cel <> "" Then Ag.Add Item:=cel.Value, Key:=CStr(cel.Value) End If Next For Each a In Ag On Error Resume Next Set wsChk = Sheets(a) If wsChk Is Nothing Then Sheets("Vuoto").Copy After:=Sheets(Sheets.Count) ActiveSheet.Name = a End If Set wsChk = Nothing Next For i = 7 To Rw If .Cells(i, 7) <> "" Then Sh = .Cells(i, 7) LR = Sheets(Sh).Cells(Rows.Count, 2).End(xlUp).Row + 1 .Cells(i, 10).Copy Sheets(Sh).Cells(LR, 2) .Cells(i, 19).Copy Sheets(Sh).Cells(LR, 4) Next End With For i = 4 To Sheets.Count With Sheets(i) .Columns(5).ClearContents Rw = .Cells(Rows.Count, "d").End(xlUp).Row .Cells(Rw, "E").Formula = "=Sum(d2:d" & Rw & ")" End With Next Sheets(1).Activate Application.ScreenUpdating = True End Sub
Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )Cia Albatros,
grazie per l'aiuto,
ma quello che mi serve è avere i raggruppamenti e i sub_totali nel Foglio SAL1, quindi un cosice da inserire e adattare gia quello che ho fatto io, il tuo codice crea tre fogli separati,
ma se provi il mio, vedi e spero che capisci quello che mi serve.
in pratica nel foglio SAL1 il mio codice, attualmente raggruppa per articoli, ma quello che mi serve, e che faccia prima i sub totali per WBS e poi per codice.
in pratica prima deve raggruppare per WSB e nella WBS deve raggruppare per Articolo.
il risultato che mi serve deve essere simile a quello che fa il mio codice.
intanto grazie e se non abbiamo più modo di risentirci ti auguro buone feste.
Adesso sono in vacanza per il Forum
Incolla il codice sul file che hai allegato, dovrebbe fare quello che hai chiesto in linea di massima, lo devi solo affinare
Sub AlbatrosComputoMetrico1() Dim Ag As New Collection Application.ScreenUpdating = False Range("G7").Select ActiveWorkbook.Worksheets("SAL N°1").Sort.SortFields.Clear ActiveWorkbook.Worksheets("SAL N°1").Sort.SortFields.Add Key:=Range("G7:G63") _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("SAL N°1").Sort .SetRange Range("A6:S63") .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With With Sheets("SAL N°1") On Error Resume Next Rw = .Cells(Rows.Count, 7).End(xlUp).Row Set Rng = Range(.Cells(7, 7), .Cells(Rw, 7)) For Each cel In Rng If cel <> "" Then Ag.Add Item:=cel.Value, Key:=CStr(cel.Value) End If Next End With colonna = 7 For Each a In Ag For Each cel In Rng If cel = a Then riga = cel.Row End If Next Range("g" & riga).Select ActiveCell.Offset(0, 13) = a ActiveCell.Offset(0, 14).Formula = "=Sum(s" & colonna & ":s" & riga & ")" colonna = riga + 1 Next RipristinaFormati 'si richiama la macro per ripristinare i formati delle celle Colora 'si richiama la macro per colorare fonts e celle split_cellatotale End SubQual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )intanto grazie mille
e buone vacanze.
ma soprattutto buone feste e buon Anno nuovo
Ciao @dodi, buone vacanze anche a te.
Prova a vedere se questa procedura fa quello che ti serve. Inseriscila in un Modulo Standard e lanciala. Ordina prima per WBS, poi per ARTICOLO. Dopo ordinato scorre lungo la colonna "G" e quando incontra un nuovo WBS allora inserisce una nuova riga e scrive il totale delle Quantità e degli Importi. Poi scorre lungo la colonna "J" e quando trova Articoli diversi fa la stessa cosa dei WBS:
Option Explicit Sub ordinaWBS_e_Articoli_con_SubTotali() Dim ws As Worksheet Dim rng As Range Dim ur As Long, i As Long, x As Long Dim wbs As String, wbsPrecedente As String, articolo As String, artPrecedente As String Dim quantita As Double, importo As Double Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets("SAL N°1") ur = ws.Cells(Rows.Count, "G").End(xlUp).Row Set rng = ws.Range("A6:S" & ur) rng.Sort Key1:=ws.Range("G6"), Order1:=xlAscending, Key2:=ws.Range("J6"), Order2:=xlAscending, Header:=xlYes i = 7 x = 7 wbsPrecedente = ws.Cells(i, "G").Value artPrecedente = ws.Cells(i, "J").Value Do While i <= ur wbs = ws.Cells(i, "G").Value If wbs <> wbsPrecedente Then ws.Rows(i).Insert shift:=xlDown ws.Rows(i).Font.Bold = True ws.Range("A" & i & ":S" & i).Interior.Color = vbGreen ws.Range("G" & i).Value = "Totale WBS " & ws.Range("G" & i - 1).Value ws.Cells(i, "Q").Value = quantita If ws.Cells(i, "Q").Value < 0 Then ws.Cells(i, "Q").Font.Color = vbRed Else ws.Cells(i, "Q").Font.Color = vbWhite End If ws.Cells(i, "S").Value = importo If ws.Cells(i, "S").Value < 0 Then ws.Cells(i, "S").Font.Color = vbRed Else ws.Cells(i, "S").Font.Color = vbWhite End If quantita = 0 importo = 0 Do While x <= i articolo = ws.Cells(x, "J").Value If articolo <> artPrecedente Then ws.Rows(x).Insert shift:=xlDown ws.Rows(x).Font.Bold = True ws.Range("A" & x & ":S" & x).Interior.Color = RGB(192, 192, 192) ws.Range("K" & x).Value = "Totale" ws.Cells(x, "Q").Value = quantita ws.Cells(x, "Q").Interior.Color = vbBlack If ws.Cells(x, "Q").Value < 0 Then ws.Cells(x, "Q").Font.Color = vbRed Else ws.Cells(x, "Q").Font.Color = vbWhite End If ws.Cells(x, "S").Value = importo ws.Cells(x, "S").Interior.Color = vbBlack If ws.Cells(x, "S").Value < 0 Then ws.Cells(x, "S").Font.Color = vbRed Else ws.Cells(x, "S").Font.Color = vbWhite End If quantita = 0 importo = 0 x = x + 1 i = i + 1 End If quantita = quantita + ws.Cells(x, "Q").Value importo = importo + ws.Cells(x, "S").Value artPrecedente = articolo x = x + 1 Loop x = i + 1 artPrecedente = ws.Cells(x, "J").Value ur = ws.Cells(Rows.Count, "A").End(xlUp).Row quantita = 0 importo = 0 i = i + 1 End If quantita = quantita + ws.Cells(i, "Q").Value importo = importo + ws.Cells(i, "S").Value wbsPrecedente = wbs i = i + 1 Loop ws.Rows(i).Font.Bold = True ws.Range("A" & i & ":S" & i).Interior.Color = vbGreen ws.Range("G" & i).Value = "Totale WBS " & ws.Range("G" & ur).Value ws.Cells(i, "Q").Value = quantita If ws.Cells(i, "Q").Value < 0 Then ws.Cells(i, "Q").Font.Color = vbRed Else ws.Cells(i, "Q").Font.Color = vbWhite End If ws.Cells(i, "S").Value = importo If ws.Cells(i, "S").Value < 0 Then ws.Cells(i, "S").Font.Color = vbRed Else ws.Cells(i, "S").Font.Color = vbWhite End If quantita = 0 importo = 0 Do While x <= i articolo = ws.Cells(x, "J").Value If articolo <> artPrecedente Then ws.Rows(x).Insert shift:=xlDown ws.Rows(x).Font.Bold = True ws.Range("A" & x & ":S" & x).Interior.Color = RGB(192, 192, 192) ws.Range("K" & x).Value = "Totale" ws.Cells(x, "Q").Value = quantita ws.Cells(x, "Q").Interior.Color = vbBlack If ws.Cells(x, "Q").Value < 0 Then ws.Cells(x, "Q").Font.Color = vbRed Else ws.Cells(x, "Q").Font.Color = vbWhite End If ws.Cells(x, "S").Value = importo ws.Cells(x, "Q").Interior.Color = vbBlack If ws.Cells(x, "S").Value < 0 Then ws.Cells(x, "S").Font.Color = vbRed Else ws.Cells(x, "S").Font.Color = vbWhite End If quantita = 0 importo = 0 x = x + 1 i = i + 1 End If quantita = quantita + ws.Cells(x, "Q").Value importo = importo + ws.Cells(x, "S").Value artPrecedente = articolo x = x + 1 Loop Set rng = Nothing Set ws = Nothing Application.ScreenUpdating = True MsgBox "Finito!" End SubCiao Alex,
buone feste anche a te,
ringrazio per l'aiuto preziosissimo, il tuo codice fa quello che mi serviva,
ti chiedo solo una cosina,
è possibile far in modo che il codice non sia vincolato alnome del Foglio SAL N° 1, ma sia eseguibile nel foglio aperto?
mi spiego meglio, questo codice, attualmente funziona nel folgio SAL n° 1, ma se ho un Foglio SAL n° 2 , SAL n° 3 e così via va giustamente in blocco,
occorre che sia eseguibile nel foglio attivo.
POI
sulla riga del totale della WBS ho visto che l'hai impostata di colore Verve, (mi piace) ma come faccio a cambiare in Font Dei numeri su quella riga? ora risulta essere bianco, quindi non si legge bene, In più chiedo se è possibile
farlo diventare Nero e di dimensioni leggermente più grande? dimensioni carattere 14.
resto in attesa ancora di tuo aiuto.
SISTEMATO QUESTE DUE COSINE METTO RISOLTO.
OPSS aggiungo, puoi aggiungere anche la riga Totale dei SUB_TOTALI delle WBS, in pratica avere il totale assoluto del computo.
inoltre ho notato che alcuni campi di subTotali non sono formattati allo stesso modo, Prova a fare la prova, e vedi che nei subTotali dell'ultima WBS i campi sono grigi e non Neri come gli altri.
Ancora grazie
Ciao, domani mattina gli do uno sguardo e ti aggiorno.
Ciao dodi, buon Natale...vedi se così va bene:
Option Explicit Sub ordinaWBS_e_Articoli_con_SubTotali() Dim ur As Long, i As Long, x As Long Dim wbs As String, wbsPrecedente As String, articolo As String, artPrecedente As String Dim quantita As Double, importo As Double Dim totWBS_Quantita As Double, totWBBS_Importo As Double Application.ScreenUpdating = False ur = Cells(Rows.Count, "G").End(xlUp).Row Range("A6:S" & ur).Sort Key1:=Range("G6"), Order1:=xlAscending, Key2:=Range("J6"), Order2:=xlAscending, Header:=xlYes i = 7 x = 7 wbsPrecedente = Cells(i, "G").Value artPrecedente = Cells(i, "J").Value Do While i <= ur wbs = Cells(i, "G").Value If wbs <> wbsPrecedente Then Rows(i).Insert shift:=xlDown Rows(i).Font.Bold = True Rows(i).Font.Size = 14 Range("A" & i & ":S" & i).Interior.Color = RGB(146, 208, 80) Range("G" & i).Value = "Totale WBS " & Range("G" & i - 1).Value Cells(i, "Q").Value = quantita Cells(i, "Q").Font.Color = IIf(quantita < 0, vbRed, vbBlack) Cells(i, "S").Value = importo Cells(i, "S").Font.Color = IIf(importo < 0, vbRed, vbBlack) totWBS_Quantita = totWBS_Quantita + quantita totWBBS_Importo = totWBBS_Importo + importo quantita = 0 importo = 0 Do While x <= i articolo = Cells(x, "J").Value If articolo <> artPrecedente Then Rows(x).Insert shift:=xlDown Rows(x).Font.Bold = True Range("A" & x & ":S" & x).Interior.Color = RGB(192, 192, 192) Range("K" & x).Value = "Totale" Cells(x, "Q").Value = quantita Cells(x, "Q").Interior.Color = vbBlack Cells(x, "Q").Font.Color = IIf(quantita < 0, vbRed, vbWhite) Cells(x, "S").Value = importo Cells(x, "S").Interior.Color = vbBlack Cells(x, "S").Font.Color = IIf(importo < 0, vbRed, vbWhite) quantita = 0 importo = 0 x = x + 1 i = i + 1 End If quantita = quantita + Cells(x, "Q").Value importo = importo + Cells(x, "S").Value artPrecedente = articolo x = x + 1 Loop x = i + 1 artPrecedente = Cells(x, "J").Value ur = Cells(Rows.Count, "A").End(xlUp).Row quantita = 0 importo = 0 i = i + 1 End If quantita = quantita + Cells(i, "Q").Value importo = importo + Cells(i, "S").Value wbsPrecedente = wbs i = i + 1 Loop With Rows(i).Font .Bold = True .Size = 14 End With Range("A" & i & ":S" & i).Interior.Color = RGB(146, 208, 80) Range("G" & i).Value = "Totale WBS " & Range("G" & ur).Value Cells(i, "Q").Value = quantita Cells(i, "Q").Font.Color = IIf(quantita < 0, vbRed, vbBlack) Cells(i, "S").Value = importo Cells(i, "S").Font.Color = IIf(importo < 0, vbRed, vbBlack) Rows(i + 2).Font.Bold = True Rows(i + 2).Font.Size = 14 Range("A" & i + 2 & ":S" & i + 2).Interior.Color = RGB(146, 208, 80) Range("G" & i + 2).Value = "Subtotale WBS" Cells(i + 2, "Q").Value = totWBS_Quantita + quantita Cells(i + 2, "Q").Font.Color = IIf(totWBS_Quantita < 0, vbRed, vbBlack) Cells(i + 2, "S").Value = totWBBS_Importo + importo Cells(i + 2, "S").Font.Color = IIf(totWBBS_Importo < 0, vbRed, vbBlack) quantita = 0 importo = 0 Do While x <= i articolo = Cells(x, "J").Value If articolo <> artPrecedente Then Rows(x).Insert shift:=xlDown Rows(x).Font.Bold = True Range("A" & x & ":S" & x).Interior.Color = RGB(192, 192, 192) Range("K" & x).Value = "Totale" Cells(x, "Q").Value = quantita Cells(x, "Q").Interior.Color = vbBlack Cells(x, "Q").Font.Color = IIf(quantita < 0, vbRed, vbWhite) Cells(x, "S").Value = importo Cells(x, "S").Interior.Color = vbBlack Cells(x, "S").Font.Color = IIf(importo < 0, vbRed, vbWhite) quantita = 0 importo = 0 x = x + 1 i = i + 1 End If quantita = quantita + Cells(x, "Q").Value importo = importo + Cells(x, "S").Value artPrecedente = articolo x = x + 1 Loop Application.ScreenUpdating = True MsgBox "Finito!" End SubP.S. dovresti allargare la colonna "Q" per visualizzare i dati contenuti nelle celle
Grande ALEX, Grazie mille,
funziona tutto come voluto,
ringraziooooo
Login
Registrati
Stai vedendo 11 articoli - dal 1 a 11 (di 11 totali)
Stai vedendo 11 articoli - dal 1 a 11 (di 11 totali)