Copia tra due fogli con somma stessa data

[BOLDOS75Partecipante BOLDOS75]

Buongiorno, avrei bisogno di un aiuto per creare una macro che mi facesse una copia tra due foglio.

Mi spiego, nel file che allego contenente solo date e valori senza codice, vorrei che nel foglio1 Colonna A fino alla riga 26, inserisco delle date  e valori in colonna B fino alla riga 26,che possono variare, ma è possibile che mi possa trovare nella situazione che ad esempio in tre righe consecutive abbia la stessa data, vorrei sommare tutte le righe che anno la stessa data e il risultato lo copiasse nel foglio2 con la stessa data. Ma nel foglio2 la data è una sola, quindi la somma delle celle in colonna B foglio1 il totale  va messo nella colonna B alla riga in cui trova la data.

Grazie

Uso MSOPP2021

 

Allegati:

You must be logged in to view attached files.

[Marius44Moderatore Marius44 Karma: 58 pts]

Ciao

Se ho capito bene, perchè scomodare VBA?

Prova con questa formula da inserire nella cella B1 del secondo foglio e copia in basso

=SOMMA.SE(Foglio1!$A$1:$A$26;Foglio2!$A1;Foglio1!$B$1:$B$26)

Ciao,

Mario

[alexps81Moderatore alexps81 Karma: 55 pts]

Se invece hai bisogno di scomodare   il VBA prova questa:

Option Explicit

Sub Totale_stessa_data()
Dim i As Byte, x As Byte
Dim tot As Double

Application.ScreenUpdating = False

For i = 1 To 26
    For x = 1 To 26
        If CDate(Foglio1.Cells(i, 1)) = CDate(Foglio1.Cells(x, 1)) Then
            tot = tot + Foglio1.Cells(x, 2).Value
        End If
    Next x
    Foglio2.Cells(i, 1) = Foglio1.Cells(i, 1)
    Foglio2.Cells(i, 2) = tot
    tot = 0
Next i

Foglio2.Activate

Application.ScreenUpdating = True

End Sub

Un saluto a @marius44   

[alexps81Moderatore alexps81 Karma: 55 pts]

Ahhh no no scusa ho riletto meglio e la mia soluzione non è quella che serve a te. Ora sistemo appena posso

[Aldo ErcoliniPartecipante Aldo Ercolini Karma: 19 pts]

Prova anche quest

Option Explicit
Dim Confronto As Date
Dim C As Range
Dim Uriga As Long, NrUlRiga As Long, a As Long, Totale As Double

Private Sub CommandButton1_Click()
        
    Application.ScreenUpdating = False
    NrUlRiga = Worksheets("Foglio1").Range("A" & Rows.Count).End(xlUp).Row
    OrdinaPerData
    
    For a = 1 To NrUlRiga
        
        If a > 1 Then
            
            If Worksheets("Foglio1").Cells(a, 1).Value <> Confronto Then
                With Worksheets("Foglio2")
                    Uriga = .Range("A" & Rows.Count).End(xlUp).Row
                    
                    With .Range("A1:A" & Uriga)
                        Set C = .Find(Confronto, LookIn:=xlValues, LookAt:=xlWhole)
                
                        If C Is Nothing Then
                            MsgBox "Data non trovata"
                        Else
                            C.Offset(, 1).Value = Totale
                            Totale = 0
                        End If
                
                    End With
            
                End With
                    
            End If
            
        End If
        
        Confronto = Worksheets("Foglio1").Cells(a, 1).Value
        Totale = Totale + Worksheets("Foglio1").Cells(a, 2).Value
    Next a
        
    Application.ScreenUpdating = True
    
End Sub
Sub OrdinaPerData()

    With Sheets("Foglio1").Sort.SortFields
        .Clear
        .Add2 Key:=Range("A1:A26"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    End With
    
    With Sheets("Foglio1").Sort
        .SetRange Range("A1:B26")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
End Sub
`

a

[alexps81Moderatore alexps81 Karma: 55 pts]

Dovrebbe essere così. Ho utilizzato le Dictionary

Option Explicit

Sub Totale_stessa_data()
Dim dict As Object
Dim i As Byte
Dim tot As Double
Dim data

Application.ScreenUpdating = False

Set dict = CreateObject("Scripting.Dictionary")

For i = 1 To 26
    data = DateValue(Foglio1.Cells(i, 1))
    tot = Foglio1.Cells(i, 2).Value
    
    If dict.Exists(data) Then
        dict(data) = dict(data) + tot
    Else
        dict.Add data, tot
    End If
    
Next i

Foglio2.Activate

i = 1
For Each data In dict.keys
    Cells(i, 1).Value = data
    Cells(i, 2).Value = dict(data)
    i = i + 1
    
Next data

Set dict = Nothing

Application.ScreenUpdating = True`

End Sub

[scossaPartecipante scossa Karma: 37 pts]

Marius44 ha scritto:

perchè scomodare VBA?

Condivido pienamente   

Ma, se proprio vogliamo scomodarlo ....

Sub AggregaDate()
  Dim rngFrm As Range, rngTo As Range, rCell As Range
  Dim nTot As Single
  
  Set rngTo = Foglio2.Range("A1").CurrentRegion.Columns(1)
  Set rngFrm = Foglio1.Range("A1:B26")
  
  For Each rCell In rngTo.Cells
    rCell.Offset(0, 1).Value = Evaluate("SUMIF(Foglio1!A1:A26, Foglio2!" & rCell.Address & ",Foglio1!B1:B26)")
  Next rCell
  
  Set rngFrm = Nothing
  Set rngTo = Nothing
End Sub

[BOLDOS75Partecipante BOLDOS75]

Buonasera, ho provato le due soluzioni proposte sembra che quella #46793 faccia al caso mio, ma mi va in errore, allego il file con i due codici.

 

Allegati:

You must be logged in to view attached files.

[BOLDOS75Partecipante BOLDOS75]

Scusate ho inserito anche codice proposto da "scossa" e mi sembra che funzioni alla perfezione allego file.

Allegati:

You must be logged in to view attached files.

[scossaPartecipante scossa Karma: 37 pts]

alexps81 ha scritto:

Ho utilizzato le Dictionary

Ciao Alessandro,

permettimi un'osservazione. Se vogliamo usare la libreria Dictionary allora vediamo di sfruttarla: visto che l'oggetto Dictionary prevede il metodo .Items possiamo evitare di leggere i singoli item per scriverli singolarmente nelle celle del Foglio2, ma possiamo farlo con una sola istruzione. In questo modo evitiamo il ciclo For e non serve nemmeno congelare lo screen:

Sub Totale_stessa_data()
  Dim dict As Object
  Dim i As Long
  Dim tot As Double
  Dim data
    
  Set dict = CreateObject("Scripting.Dictionary")
  
  For i = 1 To 26
    data = DateValue(Foglio1.Cells(i, 1))
    tot = Foglio1.Cells(i, 2).Value
    
    If dict.Exists(data) Then
        dict(data) = dict(data) + tot
    Else
        dict.Add data, tot
    End If
  Next i
  
  With Foglio2
    .Range("B1:B" & dict.Count).Value = Application.Transpose(dict.Items)
  End With
  
  Set dict = Nothing

End Sub

[alexps81Moderatore alexps81 Karma: 55 pts]

Grazie per la dritta @scossa   

[alexps81Moderatore alexps81 Karma: 55 pts]

Ciao @scossa mi sorgeva un piccolo dubbio. Il mio codice prevede che nella colonna A del Foglio2, venissero riportate le date (che nel mio esempio sono le keys)

Come dovrei fare per trasferire con il tuo esempio anche le date? Da quello che leggo trasferisco solo il totale dei valori giusto? Non ho avuto ancora modo di provarlo il tuo esempio, infatti sto scrivendo da smartphone... però così come leggo sembrerebbe che trasferisce solo quelli.

Grazie 

[alexps81Moderatore alexps81 Karma: 55 pts]

Ok sembra che possa rispondermi da solo. Ho aggiunto questa linea di codice:

With Foglio2
    .Range("A1:A" & dict.Count).Value = Application.Transpose(dict.keys)
.......
.......

[BOLDOS75Partecipante BOLDOS75]

Buonasera, nel file che allego quando copio da foglio 1  in foglio 2 nella colonna B mi trovo dei valori 0,00 come faccio ad eliminare solo le celle che contengono lo 0,00.

Allegati:

You must be logged in to view attached files.

[alexps81Moderatore alexps81 Karma: 55 pts]

@BALDOS75 come sarebbe che stai utilizzando la soluzione di @scossa???        Guarda che l'idea delle Dictionary è la mia...scherzo ovviamente...anzi ringrazio @scossa per dritte fornite.

Comunque io rispolvererei ancora la soluzione del ciclo per andare a valutare se quell'Items ha valore "0" e nel frattempo scrivere nella colonna "B" del Foglio2.

Comunque se ci sono ulteriori consigli (magari sempre di @scossa) accettiamo volentieri.

Ti darei giusto qualche consiglio:

1) la macro in questione inseriscila in un Modulo Standard anziché nel Modulo del Foglio1.

2) il pulsante che hai messo sul Foglio1, io lo sostituirei con una Forma rettangolare (Shapes) anziché utilizzare un controllo ActiveX. Vai nella scheda INSERISCI--->FORME--->e disegni un rettangolo. A quel punto gli assegni la macro "Sub Totale_stessa_data()"

3) nella macro hai inserito questa linea di codice:

MsgBox "Verifica la COPIA(xxxx)  NELLA CELLA ", vbYesNo + vbQuestion, "AVVISO" '--Modifica

qui ci sono 2 errori. Il primo è che tu utilizzando vbQuestion stai facendo una domanda, ma per poterla fare devi dare la MsgBox in pasto a una variabile. A quel punto puoi scegliere SI o NO. In base al valore che assume la variabile così proseguirà il codice. Comunque capirai meglio nel codice che ti giro di seguito. L'altro errore è che questa MsgBox l'hai inserita alla fine del codice. Quindi prima fai fare tutto, poi fai la domanda. Invece devi fare al contrario.

Sub Totale_stessa_data() 'Funziona
Dim dict As Object 'Funziona
Dim i As Long 'Funziona
Dim tot As Double 'Funziona
Dim data 'Funziona
Dim items

Set dict = CreateObject("Scripting.Dictionary") 'Funziona

For i = 1 To 20 '--Modifica
    data = DateValue(Foglio1.Cells(i, 1)) 'Funziona
    tot = Foglio1.Cells(i, 2).Value 'Funziona
    If dict.Exists(data) Then 'Funziona
        dict(data) = dict(data) + tot 'Funziona
    Else 'Funziona
        dict.Add data, tot 'Funziona
    End If 'Funziona
Next i 'Funziona
    
i = MsgBox("Verifica la COPIA(xxxx)  NELLA CELLA ", vbYesNo + vbQuestion, "AVVISO") '--Modifica
If i = vbNo Then Exit Sub

i = 1

'Cicla attraverso ogni elemento del dizionario
For Each items In dict.keys
    If dict(items) = 0 Then
        dict(items) = "" 'Se la somma è uguale a zero, impostiamo il valore a ""
    End If
    Foglio2.Cells(i, 2).Value = dict(items)
    i = i + 1
Next items

Set dict = Nothing 'Funziona

End Sub 'Funziona

 

 

[BOLDOS75Partecipante BOLDOS75]

Buongiorno, alex81 il codice funziona, ma se volessi colorare lo sfondo cella quando trova lo 0 come va modificato il codice da te corretto?

[scossaPartecipante scossa Karma: 37 pts]

alexps81 ha scritto:

omunque se ci sono ulteriori consigli (magari sempre di @scossa) accettiamo volentieri.

Sempre per evitare il ciclo For, modifica così l'alimentazione di dict:

    If dict.Exists(data) Then 
        dict(data) = IIf(dict(data) + tot = 0, "", dict(data) + tot) 
    Else 
        dict.Add data, IIf(tot = 0, "", tot) 
    End If 

 

[alexps81Moderatore alexps81 Karma: 55 pts]

scossa ha scritto:

Sempre per evitare il ciclo For, modifica così l'alimentazione di dict:

Ottimo   

@baldos75...sostituisci tutta la macro con questa:

Option Explicit

Sub Totale_stessa_data() 'Funziona
Dim dict As Object 'Funziona
Dim i As Long 'Funziona
Dim tot As Double 'Funziona
Dim data 'Funziona

Set dict = CreateObject("Scripting.Dictionary") 'Funziona

i = MsgBox("Verifica la COPIA(xxxx)  NELLA CELLA ", vbYesNo + vbQuestion, "AVVISO") '--Modifica
If i = vbNo Then Exit Sub

For i = 1 To 20 '--Modifica
    data = DateValue(Foglio1.Cells(i, 1)) 'Funziona
    tot = Foglio1.Cells(i, 2).Value 'Funziona
    
    If dict.Exists(data) Then
        dict(data) = IIf(dict(data) + tot = 0, "", dict(data) + tot)
    Else
        dict.Add data, IIf(tot = 0, "", tot)
    End If

Next i 'Funziona
    
With Foglio2.Range("B1:B" & dict.Count)
    .Value = Application.Transpose(dict.items)
    .Interior.Color = xlNone
    .SpecialCells(xlCellTypeBlanks).Interior.Color = vbRed
End With

Set dict = Nothing 'Funziona

End Sub 'Funziona

....e credo che sia quella definitiva per questo Thread. Se ci sono altre richiesta anche connesse a questa discussione, fai ricorso ad una nuova. Ciao.

[BOLDOS75Partecipante BOLDOS75]

Il codice mi va benissimo, però ho notato che  se nella riga  (For i = 1 To 22  '--Modifica ) inserisco il numero 22 il codice va bene e si esegue correttamente, ma se nella riga (For i = 1 To 26    '--Modifica) metto dopo il To 23 o altri numeri superiori mi da "Errore di run time 13 tipo non corrispondente"  non riesco a capire il motivo chiedo un aiuto.

[alexps81Moderatore alexps81 Karma: 55 pts]

Se il problema lo riscontri dall'iterazione del ciclo n. 23 in poi, vuol dire che in cella "A23" del Foglio1 non hai valori

[BOLDOS75 BOLDOS75]

Scusa ma come faccio a risolvere il problema,nel foglio1 voglio utilizzare le celle  da A1 fino A26  anche se alcune sono vuote è possibile che il codice controlli anche le celle vuote?

[scossaPartecipante scossa Karma: 37 pts]

BOLDOS75 ha scritto:

Scusa ma come faccio a risolvere il problema,nel foglio1 voglio utilizzare le celle  da A1 fino A26  anche se alcune sono vuote è possibile che il codice controlli anche le celle vuote?

Non sono un moderatore, ma non puoi continuamente "spostare" l'obiettivo della tua richiesta: quella inizale è stata pienamente risolta, quindi direi che questa vada chiusa e che tu debba aprirne una nuova per questo problema, ma esponi in modo corretto e completo la tua esigenza, e non a "pezzi e mozzichi" come in questa (IMHO)   

[BOLDOS75 BOLDOS75]

Scusa allora chiudo la discussione per avere risolto il mio primo quesito. Ringrazio tutti per la collaborazione e comprensione.

[BOLDOS75Partecipante BOLDOS75]

Scusate non avevo spuntato   "Segna questa richiesta come risolta!"

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

scossa ha scritto:

Non sono un moderatore

Dovresti anche ammettere che hai gentilmente e piu' volte rifiutato   

[Autore]

Articoli