Errore copia con cella vuota e selezione data

[BOLDOS75Partecipante BOLDOS75]

Buongiorno, se possibile avrei bisogni di un aiuto, nel file che allego ho questo problema: nel foglio1 colonna C ho dei valori positivi D valori negativi che corrispondono a delle date nella colonna , vorrei copiare nel foglio2 i relativi valori nella colonna C (valori positivi) e D (valori negativi)  ma nella riga esatta dove si trova la data che corrisponde esattamente alla cella A2 del Foglio1 che varia sempre di mese in mese. Nel file di esempio in questo caso la data A2 ( 30/04/2024 ) corrisponde Foglio2 A33. Nelle colonne devono C e D Foglio2 devono essere copiate le somme del Foglio1 colonne C e D . Premesso che vorrei usare solo il codice VBA e non formule o funzioni. Il primo problema con il codice attuale quando faccio debug con F8 il primo problema mi va in errore quando inizia a trovare nelle celle  A5 data uguale consecutiva. Se sposto la ricerca data nella colonna I funziona ma mi copia sbagliato.

Provo a farlo passo passo

1) Sommo tutti valori positivi che si trovano in colonna C da C2:C29 che corrispondano alla stessa data  indipendentemente che ci siano delle celle vuote, idem per la colonna D 

2) Cerco la stessa la data in Foglio2  che corrisponda esattamente al Foglio1 A2 

3) Copio tutti i risultati in Foglio2 Colonna C (positivi) D(negativi)

4) Se possibile somma totale Foglio1 colonna B29:B30 copiarla in Foglio2 colonna I nelle stesse date.

Spero di essermi spiegato.

Ringrazio.

Uso MSOPP2021

 

 

Allegati:

You must be logged in to view attached files.

[Luca73Partecipante Luca73 Karma: 58 pts]

Ciao Nel Tuo file allegato esise una macro che si chiama copia colonna B ma non trovo quella che copia le colonna C e D

che mi sembra essere quella che ti crea problemi.

 

[BOLDOS75Partecipante BOLDOS75]

No è solo per prova, stavo provando una sola, i pulsanti sono provvisori .

 

[Luca73Partecipante Luca73 Karma: 58 pts]

Ciao,

Vedo che fai un ciclo for da 2 a 28 perchè? Così non esamini tutte le celle di foglio1 nel tuo esempio arrivano a 29

Perchè quando inserisci un elemento del dictionary e vale zero anzichè metterlo a 0 lo metti a vuoto? Così poi non riesci a sommare....

 

 

[OscarPartecipante Oscar Karma: 44 pts]

Stessa richiesta di una settimana fa  al post errore-13/#post-47097

Dove hai già ottenuto tutto quello che ti serviva da Alexp81

Ti basta utilizzare la stessa macro e cambiare solo il riferimento delle colonne di destinazione

 

Errore 13

[BOLDOS75Partecipante BOLDOS75]

È  vero ho modifica come suggerito post Alex81 ma mi incasino a trovare la data e copiare esattamente nella colonna I  e C D Foglio2 a questo passo (vedi codice VBA).

Riallego il file

'*** QUA DEVO TROVARE LA DATA CORRISPONDENTE TRA Foglio1 A1 e la data uguale nel Foflio 2 **********
'************* E COPIARE IL CONTENUTO***********************

With Foglio2.Range(("I2"), ("C2:D") & dict.Count + 1) '<<<<<<<<<<<<<<-----IL MIO ERRORE E' QUI ?
    .Value = outputArr
    .Interior.Color = xlNone
    .SpecialCells(xlCellTypeBlanks).Interior.Color = vbYellow
End With

Allegati:

You must be logged in to view attached files.

[alexps81Moderatore alexps81 Karma: 55 pts]

Ora sono fuori casa e non ho possibilità di verificare ma da quanto ho letto credo che si potrebbe utilizzare il metodo FIND e FIND.NEXT per cercare la data in colonna A del foglio2 in base al Keys del Dictionary.

[alexps81Moderatore alexps81 Karma: 55 pts]

Ciao @Baldos75

vedi se queste modifiche sono corrette:

Option Explicit

'''' Copio in Foglio2 la somma dei valori di Foglio1 con la stessa data in Foglio1
''''Il Range in Foglio1 da B2:D27 è fisso

Sub Totale_Colonne_C_D_I()
Dim dict As Object
Dim i As Long
Dim tot(1 To 3) As Double
Dim data As Variant, tempArray As Variant
Set dict = CreateObject("Scripting.Dictionary")

i = MsgBox("Verifica la COPIA nel Foglio2 Colonna B ", vbYesNo + vbQuestion, "AVVISO")
If i = vbNo Then Exit Sub

For i = 2 To 29
    data = DateValue(Foglio1.Cells(i, 1))
    
    If Not dict.Exists(data) Then
        tot(1) = 0
        tot(2) = 0
        tot(3) = 0
    Else
        tempArray = dict(data)
        tot(1) = tempArray(1)
        tot(2) = tempArray(2)
        tot(3) = tempArray(3)
    End If
    
    tot(1) = tot(1) + Foglio1.Cells(i, "B").Value
    tot(2) = tot(2) + Foglio1.Cells(i, "C").Value
    tot(3) = tot(3) + Foglio1.Cells(i, "D").Value
    
    dict(data) = tot
Next i

'==============================================================
'scrivo il dizionario in Foglio2 nel Range("B2:D" & dict.Count)
Dim outputArr() As Variant
Dim items As Variant, keys As Variant

ReDim outputArr(1 To dict.Count, 1 To 4)
keys = dict.keys
items = dict.items

For i = 1 To dict.Count
    outputArr(i, 1) = keys(i - 1)
    outputArr(i, 2) = IIf(items(i - 1)(1) = 0, "", items(i - 1)(1))  'modifica
    outputArr(i, 3) = IIf(items(i - 1)(2) = 0, "", items(i - 1)(2))  'modifica
    outputArr(i, 4) = IIf(items(i - 1)(3) = 0, "", items(i - 1)(3))  'modifica
Next i

Foglio2.Unprotect

'*** QUA DEVO TROVARE LA DATA CORRISPONDENTE TRA Foglio1 A1 e la data uguale nel Foflio 2 **********
'************* E COPIARE IL CONTENUTO***********************
Dim ur As Long, x As Long
Dim c As Range
    
ur = Foglio2.Cells(Rows.Count, "A").End(xlUp).Row

x = 1
Do While x <= UBound(outputArr)
    Set c = Foglio2.Range("A2:A" & ur).Find(What:=DateValue(outputArr(x, 1)), LookIn:=xlValues)
    If Not c Is Nothing Then
        c.Offset(, 2) = outputArr(x, 3)
        c.Offset(, 3) = outputArr(x, 4)
        c.Offset(, 8) = outputArr(x, 2)
    End If
x = x + 1
Loop
 
With Union(Foglio2.Range("C2:D" & ur), Foglio2.Range("I2:I" & ur))
    .Interior.Color = xlNone
    .SpecialCells(xlCellTypeBlanks).Interior.Color = vbYellow
End With

Foglio2.Protect

Set dict = Nothing
Set c = Nothing

End Sub

Fammi sapere...ciao

[BOLDOS75Partecipante BOLDOS75]

Grazie per la disponibilità, ho provato ad inserire il codice ma si blocca in questa riga

'********************** qua si blocca***********************
Set c = Foglio2.Range("A2:A" & ur).Find(What:=DateValue(outputArr(x, 1)), LookIn:=xlValues)

'********************** qua si blocca***********************

rimando il file con aggiunta.

Allegati:

You must be logged in to view attached files.

[alexps81Moderatore alexps81 Karma: 55 pts]

Ma hai provato tutto il codice nuovo sostituendolo con quello vecchio? Così come l'ho postato lo devi prendere e metterlo al posto di quello che avevi prima.

[BOLDOS75Partecipante BOLDOS75]

Ho cancellato il mio codice e copiato il tuo e funziona, ma se possibile vorrei che quando trova la data in questo caso (30/04/2024) in Foglio2 A33 mi si posizioni sulla cella e la evidenzi con un colore es. viola 

[alexps81Moderatore alexps81 Karma: 55 pts]

Dai però provaci tu ora   

questa è facile...secondo me ci riesci. Ti do dei suggerimenti:

trova il metodo per inserire la parte di questo trafiletto di codice all'intero del ciclo Do While...Loop

Interior.Color = RGB(..........)

chiaro è che non basta piazzarlo così com'è...manca ancora qualcosa.

[BOLDOS75Partecipante BOLDOS75]

Così è corretto ?  Se si, come faccio a rendere la cella attiva con la data giusta evidenziata con il colore ?

Questo è l'ultima richiesta poi penso di aver risolto il mio problema.

Grazie mille 

 

Do While x <= UBound(outputArr)
Set c = Foglio2.Range("A2:A" & ur).Find(What:=DateValue(outputArr(x, 1)), LookIn:=xlValues)
If Not c Is Nothing Then


c.Interior.Color = vbYellow     'AGGIUNTO
c.Font.Color = vbBlack     'AGGIUNTO
i = MsgBox("La CELLA con la DATA è CORRETTA? è SELEZIONATA? ", vbYesNo + vbQuestion, "AVVISO")    'AGGIUNTO
If i = vbNo Then Exit Sub 'AGGIUNTOc.Offset(, 2) = outputArr(x, 3)

---- COME FACCIO A ATTIVARE LA CELLA TROVATA CON (Activecell)------------



c.Offset(, 3) = outputArr(x, 4)
c.Offset(, 8) = outputArr(x, 2)
End If
x = x + 1
Loop

[alexps81Moderatore alexps81 Karma: 55 pts]

Se vedi bene io ho dichiaro la variabile c come Range (Dim c As Range)

c sarebbe la cella trovata tramite il Find ed essendo un oggetto range avrà i suoi Metodi e Proprietà: Interior.Color, Borders, Font, ecc...

Ora, tra i vari Metodi e le Proprietà di una cella, qual è quella che conosci che Sele..ziona una cella?

[BOLDOS75Partecipante BOLDOS75]

Scusa ma mi sto incartando da solo ,la selezione della cella lo trovata (vedi codice modificato se è giusto) ma mento proseguo con il codice e seleziona la cella successiva colonna A, vorrei che solo la prima cella quella che ha la stessa data del Foglio1 si colorasse ma le successive no, qui che mi incasino se mi puoi dare una dritta, sicuramente è una cosa semplice.

Grazie mille 

Do While x <= UBound(outputArr)   'FUNZIONA ORIGINALE
    Set c = Foglio2.Range("A2:A" & ur).Find(What:=DateValue(outputArr(x, 1)), LookIn:=xlValues)   'FUNZIONA ORIGINALE
    If Not c Is Nothing Then   'FUNZIONA ORIGINALE
''***************************************** INIZIO AGGIUNTA ***************************************
c.Select 'AGGIUNTO
c.Interior.Color = vbYellow 'AGGIUNTO
c.Font.Color = vbBlack 'AGGIUNTO
i = MsgBox("La CELLA con la DATA è CORRETTA? è SELEZIONATA? ", vbYesNo + vbQuestion, "AVVISO") 'AGGIUNTO
If i = vbNo Then Exit Sub 'AGGIUNTO
''***************************************** FINE AGGIUNTA ***************************************

        c.Offset(, 2) = outputArr(x, 3)   'FUNZIONA ORIGINALE
        c.Offset(, 3) = outputArr(x, 4)   'FUNZIONA ORIGINALE
        c.Offset(, 8) = outputArr(x, 2)   'FUNZIONA ORIGINALE
    End If   'FUNZIONA ORIGINALE
'      End If 'AGGIUNTO
    
x = x + 1   'FUNZIONA ORIGINALE
Loop   'FUNZIONA ORIGINALE

[BOLDOS75Partecipante BOLDOS75]

Probabile che abbia trovato la soluzione ,avendo inserito  modifiche (codice VBA) sembra funzioni è corretto ?

Do While x <= UBound(outputArr)   'FUNZIONA ORIGINALE
    Set c = Foglio2.Range("A2:A" & ur).Find(What:=DateValue(outputArr(x, 1)), LookIn:=xlValues)   'FUNZIONA ORIGINALE
    If Not c Is Nothing Then   'FUNZIONA ORIGINALE

''***************************************** INIZIO AGGIUNTA ***************************************
c.Select 'AGGIUNTO
 If x = 1 Then
  c.Interior.Color = vbYellow 'AGGIUNTO
   c.Font.Color = vbBlack 'AGGIUNTO
i = MsgBox("La CELLA con la DATA è CORRETTA? è SELEZIONATA? ", vbYesNo + vbQuestion, "AVVISO") 'AGGIUNTO
 If i = vbNo Then Exit Sub 'AGGIUNTO
   End If 'AGGIUNTO

If ActiveCell.Value = 2 Then 'AGGIUNTO
Else 'AGGIUNTO
   End If 'AGGIUNTO
   
''***************************************** FINE AGGIUNTA ***************************************
            c.Offset(, 2) = outputArr(x, 3)   'FUNZIONA ORIGINALE
        c.Offset(, 3) = outputArr(x, 4)   'FUNZIONA ORIGINALE
        c.Offset(, 8) = outputArr(x, 2)   'FUNZIONA ORIGINALE
    End If   'FUNZIONA ORIGINALE
x = x + 1   'FUNZIONA ORIGINALE
Loop   'FUNZIONA ORIGINALE

[alexps81Moderatore alexps81 Karma: 55 pts]

Sinceramente non ho ben inteso né quello che hai fatto con le modifiche né quello che vuoi ottenere. Quello che è certo è che stiamo andando fuori tema rispetto alla richiesta iniziale. Ti provo a girare un ultimo (parte) di codice che dovrai sostituire a quello corrispondente in tuo possesso. Vediamo se ho capito:

.......
.......
Do While x <= UBound(outputArr)
    Set c = Foglio2.Range("A2:A" & ur).Find(What:=DateValue(outputArr(x, 1)), LookIn:=xlValues)
    If Not c Is Nothing Then
        If x = 1 Then
            c.Interior.Color = vbYellow
            c.Font.Color = vbBlack
            c.Select
        End If
        c.Offset(, 2) = outputArr(x, 3)
        c.Offset(, 3) = outputArr(x, 4)
        c.Offset(, 8) = outputArr(x, 2)
    End If
x = x + 1
Loop
.......
.......

Non mi è chiaro a cosa ti serve questa ulteriore procedura e comunque quando ci metti in mezzo una MessageBox con un Exit Sub in modo così brutale...anche no direi   .

A cosa serve quel MsgBox?

[BOLDOS75Partecipante BOLDOS75]

a verificare se ha selezionato la cella con la data giusta

[BOLDOS75Partecipante BOLDOS75]

Ciao alexps81  

Il MessageBox con un Exit Sub solo per provare.

Una mia curiosità, ma è possibile selezionare le righe e le colonne che mi ha copiato, in C,D,I vedo da variabili locali ha copiato 21 righe (variabile x), la selezione dovrebbe partire dalla data iniziale trovata e copiare per la  (variabile x) 21 righe, devo partire da ( outputArr(1,1) ) vedo che è la prima data con ultima ( outputArr(20,1) ,se è troppo il disturbo posso farne anche a meno, mi basta già i preziosi consigli e esempi che mi hai suggerito.  

 

[BOLDOS75Partecipante BOLDOS75]

Buonasera, finalmente sono riuscito a concludere il mio codice come volevo ringrazio ancora tutti per la collaborazione e preziosi suggerimenti ,con questo chiudo la discussione.

Ps: posto il mio pezzo di codice magari ci sono delle ripetizioni tutti Msgbox li ho inseriti per prova poi li tolgo

'**************************************** INIZIO AGGIUNTA ***************************************
Dim res As VbMsgBoxResult 'AGGIUNTO
Dim pausa, inizio 'AGGIUNTO
Dim numRows As Integer 'AGGIUNTA
''
Dim numColumns As Integer 'AGGIUNTA
''
numRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
''
i = MsgBox("La COPIA nel Foglio2 Colonna C è CORRETTA? ", vbYesNo + vbQuestion, "AVVISO") 'AGGIUNTO
 If i = vbNo Then Exit Sub 'AGGIUNTO
''
 c.Select 'AGGIUNTO
  c.Interior.Color = vbCyan 'AGGIUNTO
   c.Font.Color = vbBlack 'AGGIUNTO
''
 i = MsgBox("Seleziona Celle da Cancellare? ", vbYesNo + vbQuestion, "AVVISO") 'AGGIUNTO
  If i = vbNo Then Exit Sub 'AGGIUNTO
''
x = x - 2 'AGGIUNTA
 ActiveCell.Offset(-x, 2).Resize(numRows + x, numColumns + 1).Select 'AGGIUNTA
''
i = MsgBox("CONTROLLA  LA SELEZIONE CELLE ", vbYesNo + vbQuestion, "AVVISO") 'AGGIUNTO
 If i = vbNo Then Exit Sub 'AGGIUNTO
''
 pausa = 3 '  3 = secondi  'AGGIUNTO
  inizio = Timer  'AGGIUNTO
   Do While Timer < inizio + pausa  'AGGIUNTO
    DoEvents 'passa il controllo ad altri processi, lascia lavorare in Excel  'AGGIUNTO
     Loop  'AGGIUNTO
''
res = MsgBox(Prompt:="HAI CONTROLLATO?", _
Buttons:=vbYesNo + vbQuestion) 'AGGIUNTA
If res = vbNo Then 'AGGIUNTA
''
MsgBox Prompt:="Hai deciso uscire - Ciao!", _
Title:="A Presto!" 'AGGIUNTO
Exit Sub 'AGGIUNTO
End If 'AGGIUNTO
''
res = MsgBox(Prompt:="VUOI CANCELLARE LE CELLE SELEZIONATE ?", _
Buttons:=vbYesNo + vbQuestion) 'AGGIUNTA
If res = vbNo Then 'AGGIUNTA
Exit Sub 'AGGIUNTA
End If 'AGGIUNTA
''
ActiveCell.Interior.ColorIndex = xlNone 'scegliete un colore 'AGGIUNTO
Selection.ClearContents 'AGGIUNTO
    With Selection.Interior 'AGGIUNTO
        .Pattern = xlNone 'AGGIUNTO
    End With 'AGGIUNTO
''
c.Select 'AGGIUNTA
''
res = MsgBox(Prompt:="VUOI CANCELLARE lo sfondo ?", _
Buttons:=vbYesNo + vbQuestion) 'AGGIUNTA
ActiveCell.Interior.ColorIndex = xlNone 'scegliete un colore 'AGGIUNTA
''
x = -x 'AGGIUNTA
 ActiveCell.Offset(x, 0).Select 'AGGIUNTA
''
res = MsgBox(Prompt:="VUOI CANCELLARE LA PRIMA DATA ?", _
Buttons:=vbYesNo + vbQuestion) 'AGGIUNTA
''
ActiveCell.Interior.ColorIndex = xlNone 'scegliete un colore 'AGGIUNTA
''
res = MsgBox(Prompt:="HO FINITO CHIUDO TUTTO ?", _
Buttons:=vbYesNo + vbQuestion) 'AGGIUNTA
''***************************************** FINE AGGIUNTA ****************************************

[Autore]

Articoli