Condividi:        

Macro per estrarre e calcolare dati da un foglio ad un altro

Vuoi potenziare i tuoi documenti Word? Non sai come si fa una macro in Excel? Devi creare una presentazione in PowerPoint?
Oppure sei passato a OpenOffice e non sei sicuro di come lavorare al meglio?

Moderatori: Anthony47, Flash30005

Macro per estrarre e calcolare dati da un foglio ad un altro

Postdi Extrude » 02/07/10 03:35

Salve a tutti.... (grazie in anticipo per l'aiuto che vorrete darmi)
il mio "problemino" e' questo:
in un foglio ho una serie di tabelle (formattate anche con bordi) separate da un numero di righe variabili
ogni tabella e' composta da:
Colonna A prima riga ho solo il nome tabella (Ledger n dove per n ho un numero progressivo in funzione del numero di tabelle)
sotto al nome ho la tabella cosi' formattata:
in 2 righe (unite) i vari titoli della tabella:
Colonna A: Item
Colonna B: Description
Colonna C: Unit
Colonna D: Total Qty
Colonna E: Unit Price
Colonna F: Amount (che moltiplica i valori precedenti - DxE)
dentro alla tabella ho un numero (variabile) righe con diversi Item (che possono ripetersi in diverse tabelle)
alla fine ho una riga vuota
e la tabella si chiude con una cella unita (Colonna A e B) con scritto Total Amount ....... (dove per ..... e il lavoro specifico) e nella stessa riga in Colonna E la sommatoria dei singoli Amount calcolati nelle righe precedenti
la storia si ripete per un attuale numero di tabelle di 250 destinato ad aumentare....
Ora in tutte queste tabelle (come dicevo prima) ho degli Item che si ripetono (con i relativi valori assegnati)
finita la premessa la mia domanda e' questa:
avrei bisogno di una Macro che verifichi nel Foglio1 (dove ho l'insieme di queste tabelle, chiamaiamole di input) tutti i singloi Item, e che mi faccia una copia dell'Item (nel Foglio2) sommando i vari valori Amount se nelle tabelle di input ha trova Item uguali.
Alla fine vorrei avere nel Foglio2 (Summary) un'unica tabella (formattata come quelle di input) ma con la lista di tutti i singoli Item (in ordine alfanumerico crescente) e le relative sommatorie se trovati piu' Item nelle varie tabelle nel Foglio1.
Siccome mi sono dilungato provo a fare un esempio pratico:
se nel Foglio1 ho una situazione come questa:

Ledger 1
Item_______Description____Unit___Total Qty____Unit Price___Amount
1491-113___Scavi_________cu-m____2,922.44____6.70______19,580.35
1491-114___Riempimenti___cu-m____4,135.09___20.09______83,073.96
Total Amount for Lavoro1_______________________________102,654.31

Ledger 2
Item_______Description____Unit___Total Qty____Unit Price___Amount
1491-113___Scavi_________cu-m____1,000.00____6.70_______6,670.00
1711-006___Fondazione____cu-m____1,664.84__186.02_____309,693.54
Total Amount for Lavoro2_______________________________316,393.54

nel Foglio2 mi aspetto di trovarmi una Tabella cosi':

Summary
Item_______Description____Unit___Total Qty____Unit Price___Amount
1491-113___Scavi_________cu-m____3,922.44____6.70______26,280.35
1491-114___Riempimenti___cu-m____4,135.09___20.09______83,073.96
1711-006___Fondazione____cu-m____1,664.84__186.02_____309,693.54
Total Amount for Lavoro2_______________________________419,047.85

Spero di essere stato esaustivo (visto che non posso inviare File di esempio)
Vi prego ho urgente bisogno di aiuto e il tempo (purtroppo) non e' dalla mia parte
GRAZIE
Extrude
Utente Junior
 
Post: 28
Iscritto il: 19/06/10 07:37

Sponsor
 

Re: Macro per estrarre e calcolare dati da un foglio ad un altro

Postdi Flash30005 » 02/07/10 08:57

Ciao Extrude e benvenuto nel Forum

Non ti preoccupare, siamo noi dalla tua parte ;)

Penso che questa macro risolva i tuoi problemi
Codice: Seleziona tutto
Sub CompilaSum()
UR2 = Worksheets("Foglio2").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Foglio2").Range("A1:F" & UR2 + 3).Clear
Worksheets("Foglio2").Range("A1").Value = "Summary"
Worksheets("Foglio1").Range("A2:F2").Copy Destination:=Worksheets("Foglio2").Range("A2")
UR1 = Worksheets("Foglio1").Cells(Rows.Count, 2).End(xlUp).Row

For RR = 1 To UR1
CItem = 0
    Item1 = Worksheets("Foglio1").Range("A" & RR).Value
    If Mid(Item1, 1, 6) = "Ledger" Then GoTo Salta
    If Item1 = "Item" Then GoTo Salta
    If Mid(Item1, 1, 5) = "Total" Then GoTo Salta
    UR2 = Worksheets("Foglio2").Cells(Rows.Count, 1).End(xlUp).Row
    For RR2 = 3 To UR2
        If Item1 = Worksheets("Foglio2").Range("A" & RR2).Value Then CItem = CItem + 1
    Next RR2
    If CItem = 0 Then Sheets("Foglio1").Range("A" & RR & ":C" & RR).Copy Destination:=Sheets("Foglio2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Salta:
Next RR
    UR2 = Worksheets("Foglio2").Cells(Rows.Count, 1).End(xlUp).Row
For RR2 = 3 To UR2
    Item2 = Worksheets("Foglio2").Range("A" & RR2).Value
    For RR = 1 To UR1
        Item1 = Worksheets("Foglio1").Range("A" & RR).Value
        If Item2 = Item1 Then
            For CC = 4 To 6
                Sheets("Foglio2").Cells(RR2, CC).Value = Sheets("Foglio2").Cells(RR2, CC).Value + Sheets("Foglio1").Cells(RR, CC).Value
            Next CC
        End If
    Next RR
Next RR2
UR2 = Worksheets("Foglio2").Cells(Rows.Count, 1).End(xlUp).Row + 1
Worksheets("Foglio2").Range("A" & UR2).Value = "Total Amount"
Worksheets("Foglio2").Range("F" & UR2).FormulaR1C1 = "=SUM(R[" & 3 - UR2 & "]C:R[-1]C)"
Sheets("Foglio2").Range("D3:F" & UR2).NumberFormat = "#,##0.00"
End Sub

Il foglio delle tabelle si dovrà chiamare "Foglio1" e il foglio riepilogo "Foglio2" (poi semmai cambierai la macro secondo il nome dei tuoi fogli)
Eviterei le celle unite quindi separa le celle e se ti occorre una maggior altezza (per le righe) e/o larghezza per le colonne agisci sulla altezza/larghezza riga o colonna.

Incolla la macro in un modulo del Vba e avviala

(Ho notato che hai il Pc con impostazione dei numeri formato Internazionale non Europeo (Italia)
dove il separatore migliaia è il punto non la virgola e il decimale è virgola non punto,
Non dovresti avere, comunque, problemi)

Fai sapere
Ciao
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: Macro per estrarre e calcolare dati da un foglio ad un altro

Postdi Extrude » 02/07/10 09:33

Ciao Flash,
prima di tutto grazie per la (solita) velociata' di risposta.....

ho fatto una prova ma non funziona mi entra in Debug alla riga
If Mid(Item1, 1, 6) = "Ledger" Then GoTo Salta

Premetto che l'ho fatta girare senza modificare le unioni di riga e celle (ovvero lasciando le attuali tabelle formattate cosi' come sono (nel Foglio1) in quanto non credo che avro' il tempo necessario per modificarle tutte e anche perche' sono convinto che chi continuera' a "popolare" il Foglio1 (con ulteriori tabelle) lo continuera' a fare con questo tipo di formattazione.... (quindi bisognera' fare in modo, credo, che la macro funzioni anche in queste "estreme" condizioni)

Ho notato che in Foglio2 copia anche le righe del titolo (Ledger-n) delle varie tabelle (ma non lo dovrebbe fare), a me servono solo i dati (ITEM) copiati solo una volta e se ripetuti nelle varie tabelle mi occorre eseguire la sommatoria dei valori Total Qty (contenuti nella colonna D) e Amount (contenuti nella colonna F) come da esempio descritto in precedenza.
Noto inoltre che in Foglio2 non ha completato la copia delle colonne D, E ed F ma solo le colonne A, B e C
Suggerimenti in proposito?
Grazie ancora Flash
Extrude
Utente Junior
 
Post: 28
Iscritto il: 19/06/10 07:37

Re: Macro per estrarre e calcolare dati da un foglio ad un altro

Postdi Extrude » 02/07/10 09:45

non so se posso inviarti il file via mail in quanto dall'ufficio i siti per le condivisioni dei files sono bloccati.

Altre precisazioni che ho omesso (relative al formato numerico, nonche' all'orario di invio del post, etc....) sono: attualmente mi trovo a Singapore ed utilizzo Excel 2003 in inglese

non so se possono esserti di aiuto per la compilazione della macro.....

io provero' a ritoccarla (secondo le mie scarse conoscenze in materia VBA)

Ciao
Extrude
Utente Junior
 
Post: 28
Iscritto il: 19/06/10 07:37

Re: Macro per estrarre e calcolare dati da un foglio ad un altro

Postdi Flash30005 » 02/07/10 10:27

Hai un Mp

Separa tutte le celle (sia righe che colonne)
la testata (spero) che abbia i nomi separati es.:
In A1 Ledger 1
A2 Item
B2 Description
C2 Unit
D2 Total Qty
E2 Unit Price
F2 Amount
alla fine della tabella ci sia nella colonna
A (riga x) Total Amount for Lavo...

e poi tutte le altre tabelle

Fai sapere
Ciao
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: Macro per estrarre e calcolare dati da un foglio ad un altro

Postdi Extrude » 02/07/10 11:39

Allora (premetto che un grazie di cuore e' il minimo che possa fare....)
formattando secondo le tue ultime indicazioni inizia a funzionare.....
adesso al Foglio 2 trovo:
A1 = Summary (come da istruzioni Macro)
riga 2 le intestazioni di colonna (formattate correttamente, bordi inclusi, ma gradirei l'altezza della riga doppia rispetto alle altre si puo'??)
nelle n righe conteneti i dati (item e rispettivi valori):
la formattazione dei bordi funziona solo sulle colonne A, B e C e non su D, E e F (se si potesse capire il perche' non sarebbe male, eviterei che qualcuno formatti in maniera sbagliata)
nell'ultima riga (Total Amount) e' scritto nella cella n in Colonna A (come da istruzione Macro) ma trovo scritto nella cella n in Colonna B il testo Total Amount dell'ultima Tabella considerata (e siccome non ci dovrebbe essere scritto mi sono preso la liberta di modificare la tua "creazione" modificando l'istruzione da "A" in "B" cosi' sovrascrive il testo che si porta dietro.
Ora la cosa che non deve fare assolutamente e' quella di sommare i valori contenuti nella Colonna E (Unit Priece) quando trova Item uguali, quel valore deve rimanere invariato.
Ultima richiesta (e poi non ti "rompo" piu') nelle singole celle in colonna E (Amount) si potrebbe inserire la formula per far fare a Excel la moltiplicazione dei rispettivi valori nelle nelle Colonne D ed E anziche' copiare il testo?
questo mi permetterebbe di modificare il formato numerico (dichiarato nella Macro) ed eventualmente aggiungiere 3 cifre decimali se mi occorre.
Inoltre se si riuscisse (sicuramente si da parte tua, piu' difficle per me), vorrei avere la riga finale in grassetto

Certo della tua collaborazione mi rimane solo che ringraziare ancora (e questa volta in anticipo)

Ciao
Extrude
Utente Junior
 
Post: 28
Iscritto il: 19/06/10 07:37

Re: Macro per estrarre e calcolare dati da un foglio ad un altro

Postdi Flash30005 » 02/07/10 11:44

Leggi l'MP (Messaggio Privato), accedi dal collegamento posto in alto pagina del forum dove trovi scritto "1 nuovi messaggi privati".

Intanto vedo di apportare qualche modifica

Ciao
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: Macro per estrarre e calcolare dati da un foglio ad un altro

Postdi Flash30005 » 02/07/10 12:05

Ho fatto qualche modifica:
1) formula sulla colonna F (= D*E)
2) Formattato ciò che ho capito (semmai faremo altre piccole modifiche)
3) Non mi risulta che nel foglio2 Summary venga trascritto l'ultimo lavoro dell'ultima tabella ma scriverà sempre Total Amount perché ho pensato che fosse errato riportare il titolo (Total Ammount n, quando è un totale di tutte le tabelle) e, questo titolo viene trascritto su An e non su Bn
Ti invio l'intera macro che sostituirà la precedente

Codice: Seleziona tutto
Sub CompilaSum()
UR2 = Worksheets("Foglio2").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Foglio2").Range("A1:F" & UR2 + 3).Clear
Worksheets("Foglio2").Range("A1").Value = "Summary"
Worksheets("Foglio1").Range("A2:F2").Copy Destination:=Worksheets("Foglio2").Range("A2")
UR1 = Worksheets("Foglio1").Cells(Rows.Count, 2).End(xlUp).Row

For RR = 1 To UR1
CItem = 0
    Item1 = Worksheets("Foglio1").Range("A" & RR).Value
    If Mid(Item1, 1, 6) = "Ledger" Then GoTo Salta
    If Item1 = "Item" Then GoTo Salta
    If Mid(Worksheets("Foglio1").Range("B" & RR).Value, 1, 5) = "Total" Then GoTo Salta
    UR2 = Worksheets("Foglio2").Cells(Rows.Count, 1).End(xlUp).Row
    For RR2 = 3 To UR2
        If Item1 = Worksheets("Foglio2").Range("A" & RR2).Value Then CItem = CItem + 1
    Next RR2
    If CItem = 0 Then Sheets("Foglio1").Range("A" & RR & ":C" & RR).Copy Destination:=Sheets("Foglio2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Salta:
Next RR
    UR2 = Worksheets("Foglio2").Cells(Rows.Count, 1).End(xlUp).Row
For RR2 = 3 To UR2
    Item2 = Worksheets("Foglio2").Range("A" & RR2).Value
    For RR = 1 To UR1
        Item1 = Worksheets("Foglio1").Range("A" & RR).Value
        If Item2 = Item1 Then
            For CC = 4 To 5
                Sheets("Foglio2").Cells(RR2, CC).Value = Sheets("Foglio2").Cells(RR2, CC).Value + Sheets("Foglio1").Cells(RR, CC).Value
            Next CC
        End If
    Next RR
    Sheets("Foglio2").Cells(RR2, CC).FormulaR1C1 = "=RC[-2]*RC[-1]"
Next RR2
UR2 = Worksheets("Foglio2").Cells(Rows.Count, 1).End(xlUp).Row + 1
Worksheets("Foglio2").Range("A" & UR2).Value = "Total Amount"
Worksheets("Foglio2").Range("F" & UR2).FormulaR1C1 = "=SUM(R[" & 3 - UR2 & "]C:R[-1]C)"
Sheets("Foglio2").Range("D3:F" & UR2).NumberFormat = "#,##0.000"
Call Formatta
End Sub
Sub Formatta()
Sheets("Foglio2").Select
UR2 = Worksheets("Foglio2").Cells(Rows.Count, 1).End(xlUp).Row
    Rows("2:2").Select
    Selection.RowHeight = 25
    Range("A2:F2").Select
    Selection.Font.Bold = True
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
   

   
    Range("A" & UR2 & ":F" & UR2).Select
    Selection.Font.Bold = True
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
   
    Columns("A:A").ColumnWidth = 12.86
    Range("A1").Select
    Selection.Font.Bold = True
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
 
    Range("A1").Select
End Sub


Fai sapere
Ciao
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: Macro per estrarre e calcolare dati da un foglio ad un altro

Postdi Extrude » 02/07/10 12:25

ho caricato la nuova Macro postata e i problemi sono i seguenti:

la formattazione avviene nel Foglio1 (se lancio la Macro quando ho questo attivo)
nell'ultima riga continua a copiare il valore che trova scritto nell'ultima tabella (quindi converrai con me che forse e' meglio far scrivere Total Amount nell'ultima cella ma in Colonna B e non in A (cosi' sovrascrive il testo copiato con la Macro) giusto?
le quantita descritte in Colonna E (unit priece) continuano a non essere uguali a quelle sorgenti (nel Foglio1)

Per quanto riguara la formattazione (ora che ho visto i codici che hai usato) provero' anche io a fare qualche modifica al codice che mi hai mandato per vedere se riesco a imparare.....

.... come si suol dire: piuttosto che dar da mangiare a qualcuno, insegnagli come procurarsene.... :lol:

cosa che per altro stai facendo egregiamente (leggendo in giro per questo Forum ho potuto imparare molte nozioni a me ignote)

Grazie ancora e se riesci a finalizzare (come certamente avverra') il codice prima di me avvisami per favore

Ciao
Extrude
Utente Junior
 
Post: 28
Iscritto il: 19/06/10 07:37

Re: Macro per estrarre e calcolare dati da un foglio ad un altro

Postdi Flash30005 » 02/07/10 13:43

Gling Glong
Avvisato!

Macro completa:

Codice: Seleziona tutto
Sub CompilaSum()
UR2 = Worksheets("Foglio2").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Foglio2").Range("A1:F" & UR2 + 3).Clear
Worksheets("Foglio2").Range("A1").Value = "Summary"
Worksheets("Foglio1").Range("A2:F2").Copy Destination:=Worksheets("Foglio2").Range("A2")
UR1 = Worksheets("Foglio1").Cells(Rows.Count, 2).End(xlUp).Row

For RR = 1 To UR1
CItem = 0
    ITem1 = Worksheets("Foglio1").Range("A" & RR).Value

    If Mid(ITem1, 1, 6) = "Ledger" Then GoTo Salta
    If ITem1 = "Item" Then GoTo Salta
    If Mid(Worksheets("Foglio1").Range("B" & RR).Value, 1, 5) = "Total" Then GoTo Salta
    UR2 = Worksheets("Foglio2").Cells(Rows.Count, 1).End(xlUp).Row
    For RR2 = 3 To UR2
        If ITem1 = Worksheets("Foglio2").Range("A" & RR2).Value Then CItem = CItem + 1
    Next RR2
    Sheets("Foglio1").Range("A" & RR & ":C" & RR).Copy Destination:=Sheets("Foglio2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Salta:
Next RR
    UR2 = Worksheets("Foglio2").Cells(Rows.Count, 1).End(xlUp).Row
For RR2 = 3 To UR2
    CarS = 0
    ITem2 = Worksheets("Foglio2").Range("A" & RR2).Value
    If Trim(ITem2) = "-" Then CarS = 1
    For RR = 1 To UR1

        ITem1 = Worksheets("Foglio1").Range("A" & RR).Value

        If ITem2 = ITem1 Then
            For CC = 4 To 5
            If CItem = 0 Then Sheets("Foglio2").Cells(RR2, CC).Value = Sheets("Foglio2").Cells(RR2, CC).Value + Sheets("Foglio1").Cells(RR, CC).Value
            Next CC
        End If
    Next RR
    If CarS = 0 Then Sheets("Foglio2").Cells(RR2, CC).FormulaR1C1 = "=RC[-2]*RC[-1]"
Next RR2
UR2 = Worksheets("Foglio2").Cells(Rows.Count, 1).End(xlUp).Row + 1
Worksheets("Foglio2").Range("A" & UR2).Value = "Total Amount"
Worksheets("Foglio2").Range("F" & UR2).FormulaR1C1 = "=SUM(R[" & 3 - UR2 & "]C:R[-1]C)"
Sheets("Foglio2").Range("D3:F" & UR2).NumberFormat = "#,##0.000"
Call Formatta
End Sub
Sub Formatta()
Sheets("Foglio2").Select
UR2 = Worksheets("Foglio2").Cells(Rows.Count, 1).End(xlUp).Row
  For RR2 = 4 To UR2 - 1
  Range("A" & RR2 & ":F" & RR2).Select
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlHairline
        .ColorIndex = xlAutomatic
    End With
    Next RR2


    Rows("2:2").Select
    Selection.RowHeight = 25
    Range("A2:F2").Select
    Selection.Font.Bold = True
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
   

   
    Range("A" & UR2 & ":F" & UR2).Select
    Selection.Font.Bold = True
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
   
    Columns("A:A").ColumnWidth = 12.86
    Range("A1").Select
    Selection.Font.Bold = True
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
 
      Range("A2:F" & UR2).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Range("A1").Select
End Sub


Fai sapere tu, ora

Ciao

P.s. Molte righe di formattazione potrebbero essere eliminate in quanto superflue ma, visto che hai fretta!...
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: Macro per estrarre e calcolare dati da un foglio ad un altro

Postdi Extrude » 02/07/10 15:40

Thanks Flash......

hai un MP....

alla luce di quanto hai fatto e prodotto posso solo che dirti GRAZIE

da qui provo ad aggiustarmela io

PS: qualche dritta su come far riconoscere in VBA due valori uguali durante l'esecuzione della macro?

perché è la cosa che mi serve principalmente

CIAO
Extrude
Utente Junior
 
Post: 28
Iscritto il: 19/06/10 07:37

Re: Macro per estrarre e calcolare dati da un foglio ad un altro

Postdi Flash30005 » 02/07/10 19:02

Ho ricontrollato il tutto e ho notato che oltre ad esserci degli spazi inutili, negli Item, che compromettevano il controllo
c'era anche un bug dovuto alla fretta (oggi proprio non è giornata! :-? )

Comunque prova questa macro definitiva (spero) e fammi sapere


Codice: Seleziona tutto
Sub CompilaSum()
Application.ScreenUpdating = False
Application.Calculation = xlManual
UR2 = Worksheets("Foglio2").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Foglio2").Range("A1:F" & UR2 + 3).Clear
Worksheets("Foglio2").Range("A1").Value = "Summary"
Worksheets("Foglio1").Range("A2:F2").Copy Destination:=Worksheets("Foglio2").Range("A2")
UR1 = Worksheets("Foglio1").Cells(Rows.Count, 2).End(xlUp).Row

For RR = 1 To UR1
CItem = 0
    ITem1 = Trim(Worksheets("Foglio1").Range("A" & RR).Value)

    If Mid(ITem1, 1, 6) = "Ledger" Then GoTo Salta
    If ITem1 = "Item" Then GoTo Salta
    If Mid(Worksheets("Foglio1").Range("B" & RR).Value, 1, 5) = "Total" Then GoTo Salta
    UR2 = Worksheets("Foglio2").Cells(Rows.Count, 1).End(xlUp).Row
    For RR2 = 3 To UR2
        If ITem1 = Trim(Worksheets("Foglio2").Range("A" & RR2).Value) Then CItem = CItem + 1
    Next RR2
    If CItem = 0 Then Sheets("Foglio1").Range("A" & RR & ":C" & RR).Copy Destination:=Sheets("Foglio2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Salta:
Next RR
    UR2 = Worksheets("Foglio2").Cells(Rows.Count, 1).End(xlUp).Row
For RR2 = 3 To UR2
    CarS = 0
    ITem2 = Trim(Worksheets("Foglio2").Range("A" & RR2).Value)
    If Trim(ITem2) = "-" Then CarS = 1
    For RR = 1 To UR1

        ITem1 = Trim(Worksheets("Foglio1").Range("A" & RR).Value)

        If ITem2 = ITem1 Then
            Sheets("Foglio2").Cells(RR2, 4).Value = Sheets("Foglio2").Cells(RR2, 4).Value + Sheets("Foglio1").Cells(RR, 4).Value
            Sheets("Foglio2").Cells(RR2, 5).Value = Sheets("Foglio1").Cells(RR, 5).Value
        End If
    Next RR
    If CarS = 0 Then Sheets("Foglio2").Cells(RR2, 6).FormulaR1C1 = "=RC[-2]*RC[-1]"
Next RR2
UR2 = Worksheets("Foglio2").Cells(Rows.Count, 1).End(xlUp).Row + 1
Worksheets("Foglio2").Range("A" & UR2).Value = "Total Amount"
Worksheets("Foglio2").Range("F" & UR2).FormulaR1C1 = "=SUM(R[" & 3 - UR2 & "]C:R[-1]C)"
Sheets("Foglio2").Range("D3:F" & UR2).NumberFormat = "#,##0.000"
Call Formatta
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub Formatta()
Sheets("Foglio2").Select
UR2 = Worksheets("Foglio2").Cells(Rows.Count, 1).End(xlUp).Row
  For RR2 = 4 To UR2 - 1
  Range("A" & RR2 & ":F" & RR2).Select
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlHairline
        .ColorIndex = xlAutomatic
    End With
    Next RR2


    Rows("2:2").Select
    Selection.RowHeight = 25
    Range("A2:F2").Select
    Selection.Font.Bold = True
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
   

   
    Range("A" & UR2 & ":F" & UR2).Select
    Selection.Font.Bold = True
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
   
    Columns("A:A").ColumnWidth = 12.86
    Range("A1").Select
    Selection.Font.Bold = True
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
 
      Range("A2:F" & UR2).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Range("A1").Select
End Sub


Ciao
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: Macro per estrarre e calcolare dati da un foglio ad un altro

Postdi Extrude » 05/07/10 02:45

L'ho provata.... e funziona alla grande.....

.... ho dovuto solo ritoccare leggermente la formattazione (in quanto non piaceva al mio "BOSS") ma e' stato nulla rispetto a quanto hai fatto tu....


GRAZIE ancora per tutto e a presto
Extrude
Utente Junior
 
Post: 28
Iscritto il: 19/06/10 07:37


Torna a Applicazioni Office Windows


Topic correlati a "Macro per estrarre e calcolare dati da un foglio ad un altro":


Chi c’è in linea

Visitano il forum: Nessuno e 45 ospiti