› Sviluppare funzionalita su Microsoft Office con VBA › Copia dati tra fogli in base a data e a valore di riferimento
-
AutoreArticoli
-
Ciao a tutti.
Nei miei fogli di calcolo ho inserito alcuni moduli di codice che mi permettono, dopo input manuale di eseguire calcoli e di esportare i dati su file esterni ad uso dei colleghi.
Il codice costruito funziona ma è molto macchinoso e in caso di modifica alla tabella origine / destinazione serve agire manualmente sul codice per sistemare le divergenze.
Vorrei aiuto per definire meglio gli array di origine e destinazione o sul foglio di destinazione la mia idea era definire, in un foglio appoggio, la riga 1 = colonne origine e la riga 2= colonne destino ma non credo questo mi metta al riparo da modifiche alle tabelle.
Alternativa potrebbe essere usare l'intestazione della colonna invece di indicare la colonna di excel ma non credo sia semplice e non mi mette al riparo da modifica alle intestazioni.
grazie a chi mi potrà dare dei suggerimenti.
Global g_NomeFoglioOutput As String Public g_NomeFileOutput As String Sub Copia_Dati_Ele_Destinazione(Optional SaltaRichiesta As Boolean, Optional SaltaAggFiltro As Boolean, Optional ErroreSuFileDestino As Boolean) 'controlla che sia il pc corretto If Environ("COMPUTERNAME") <> "XXXX" Or Environ("USERNAME") <> "XXXX" Then msgbox "Utente non autorizzato", vbCritical Exit Sub End If Dim strPathDest As String Dim strNomeFileDest As String Dim strNomeFileDestCompleto As String Dim ultData As Date Dim wbkDest As Workbook Dim shtDest As Worksheet Dim shtOrigine As Worksheet Dim blEsito As Boolean Dim intRiga_O_Inizio As Integer Dim intRiga_O_Fine As Integer Dim intRiga_D_Inizio As Integer Dim datUltima As Date Dim rngO As Range Dim CellaData_O As String Dim blTrovato As Boolean Dim blFoglioDestAperto As Boolean Dim offSet_Campo1_O As Integer Dim offSet_Campo1_D As Integer Dim strValoreCellaOrig As String Dim rngD As Range Dim CellaData_D As String Dim arr_Orig() 'As String Dim arr_Dest() 'As String Dim i As Integer Dim j As Integer Dim k As Integer Dim strNomeFoglioDest As String Dim strPrimoCampoMappa As String Dim strColonnaData_O As String Dim intRigaInizio_O As Integer Dim intNumeroCampiDaCopiare As Integer Dim ColonnaOffset As String ' filtro dati su maschera Export_Ele = True If Export_Ele = False Then Exit Sub End If '************************************** ' Compilare i dati con <--- ' '************************************** Set shtOrigine = ThisWorkbook.Sheets("Letture Manuali") strPathDest = "O:\COMMESSE\22222\" strNomeFileDest = "22042 - Energia elettrica.xlsx" strNomeFoglioDest = "Ele" ' <--- nome del foglio con i dati 'Verifica se foglio destino già aperto For i = 1 To Workbooks.Count If Workbooks(i).Name = strNomeFileDest Then blFoglioDestAperto = True Exit For End If Next i 'se aperto imposta i riferimenti If blFoglioDestAperto Then Set wbkDest = Workbooks(i) Else '..lo apre strNomeFileDestCompleto = strPathDest & strNomeFileDest 'Se il file non c'è avvisa ed esce If Dir(strNomeFileDestCompleto) <> "" Then Else msgbox "Il file specificato come Destinazione dati non esiste o è stato spostato", vbCritical Exit Sub End If Set wbkDest = Workbooks.Open(strNomeFileDestCompleto, False, False) End If 'si piazza sul file destinazione Windows(strNomeFileDest).Activate ' e chiede se procedere Dim risp As String If Not SaltaRichiesta Then risp = msgbox("Il file è aperto. Vuoi procedere?", vbQuestion + vbYesNo, "Funzione MsgBox Semplice") Else risp = vbYes End If If risp = vbNo Then Exit Sub End If 'procede Set shtDest = wbkDest.Sheets(strNomeFoglioDest) arr_Orig = Array("DK", "DL", "DM", "DN", "E", "AP") ' <-- Origine arr_Dest = Array("T", "U", "V", "W", "X", "Y") ' <-- Destinazione If UBound(arr_Orig()) <> UBound(arr_Dest()) Then msgbox "Il numero di campi di Origine NON corrisponde al numero campi destinazione", vbExclamation Exit Sub End If intNumeroCampiDaCopiare = UBound(arr_Orig) + 1 '************************************** ' VERIFICA SE CI SONO DATI NUOVI '************************************** 'legge ultima data compilata strColonnaData_O = "B" ' <--- Prima cella del foglio di Origine contenente la Data intRigaInizio_O = 8 ' <-- numero di riga su Origine dove iniziano i Dati CellaData_O = "B8" ' <-- rif alla cella su Origine contenente la data da controllare (1a riga) CellaData_D = "B5" ' <-- rif alla cella su Destinazione contenente la data da controllare (1a riga) offSet_Campo1_D = 21 ' <-- num di colonne di 'distanza' tra la colonna data e colonna con dato significativo da controllare blEsito = LeggeUltimaDataDestinazione(shtDest, intRiga_D_Inizio, datUltima, CellaData_D, offSet_Campo1_D) If Not blEsito Then msgbox "Si è verificato un errore in LeggeUltimaDataDestinazione ", vbCritical Exit Sub End If 'Si posiziona su prima riga Origine successiva a data ultima Set rngO = shtOrigine.Range(CellaData_O) ' Set rngO = shtDest.Range(CellaData_O) offSet_Campo1_O = 116 ' <-- num di colonne di 'distanza' tra la colonna data e colonna con dato significativo da controllare intRiga_O_Fine = 0 intRiga_O_Inizio = 0 i = shtOrigine.UsedRange.Rows.Count blTrovato = False Do While Not blTrovato And i >= intRigaInizio_O Set rngO = shtOrigine.Range(strColonnaData_O & i) strValoreCellaOrig = rngO.Offset(, offSet_Campo1_O) 'se esiste un valore valido imposta esito ed esce If strValoreCellaOrig > vbNullString Then If intRiga_O_Fine = 0 Then intRiga_O_Fine = i If rngO.Value > datUltima Then intRiga_O_Inizio = i Else blTrovato = True End If Else If IsDate(rngO) And rngO <= datUltima Then blTrovato = True End If intRiga_O_Inizio = i End If i = i - 1 Loop 'se non trovato avvisa ed esce If intRiga_O_Inizio = 4 Then msgbox "Non ci sono nuovi dati da importare", vbInformation Exit Sub End If '********************************** ' COPIA DEI DATI '********************************** 'Inizia il ciclo leggi-scrivi k = 0 With rngO For i = intRiga_O_Inizio To intRiga_O_Fine k = k + 1 For j = 0 To intNumeroCampiDaCopiare - 1 If shtOrigine.Range(arr_Orig(j) & i).Value <> "" Then 'era vbNullString Then Set rngD = shtDest.Range(arr_Dest(j) & intRiga_D_Inizio + k) rngD.Value = shtOrigine.Range(arr_Orig(j) & i).Value rngD.Font.ColorIndex = 1 End If Next j Next i End With 'Ciclo tutte le PivotTable e le aggiorno ' ThisWorkbook.RefreshPivotTables 'Lavoro eseguito: 'salva wbkDest.Save 'chiede se aprire il programma di sincronizzazione Dim risp2_Sincro As String If Not SaltaRichiesta Then risp2_Sincro = msgbox(" Lavoro eseguito." & vbCrLf & vbCrLf & "Vuoi aprire la sincronizzazione?", _ vbQuestion + vbYesNo + vbDefaultButton2, "Funzione MsgBox Semplice") wbkDest.Save Else risp2_Sincro = vbNo End If If risp2_Sincro = vbYes Then Apri_Sincro_file_dogane End If 'se file era aperto lo lascia aperto, sennò lo chiude salvando If Not blFoglioDestAperto Then Dim risp3_chiudi As String 'chiede se chiudere il file If Not SaltaRichiesta Then risp3_chiudi = msgbox(" Lavoro eseguito!" & vbCrLf & vbCrLf & vbCrLf & " Chiudere il file?", _ vbQuestion + vbYesNo + vbDefaultButton1, "Funzione MsgBox Semplice") Else risp3_chiudi = vbYes End If If risp3_chiudi = vbYes Then 'se si wbkDest.Close True 'chiude il file e salva End If End If 'procede 'Libera memoria Set rngO = Nothing Set rngD = Nothing Set shtDest = Nothing Set wbkDest = Nothing Set shtOrigine = Nothing End Sub Private Function LeggeUltimaDataDestinazione(ByRef rWsh As Worksheet, ByRef rRiga As Integer, ByRef rDataUlt As Date, ByVal strCella As String, vOffsetData) As Boolean Dim i As Integer Dim dataUlt As Date On Error GoTo Err_LeggeUltimaDataDestinazione 'Legge ultima data compilata nel foglio DatiImp 'Inizializza rRiga = rWsh.UsedRange.Rows.Count rDataUlt = CDate("2000/01/01") With rWsh.Range(strCella) i = rWsh.UsedRange.Rows.Count Do If IsDate(.Offset(i)) Then If (.Offset(i, vOffsetData)) > "" Then rDataUlt = .Offset(i).Value rRiga = rWsh.Range(strCella).Row + i Exit Do End If End If i = i - 1 Loop End With 'Imposta esito LeggeUltimaDataDestinazione = True Exit_LeggeUltimaDataDestinazione: Exit Function Err_LeggeUltimaDataDestinazione: msgbox Err.Description, vbCritical Resume LeggeUltimaDataDestinazione = False Resume Exit_LeggeUltimaDataDestinazione End Function
Buona giornata, @danros;
sarebbe opportuno allegassi un File, senza Dati sensibili, con alcuni Record significativi già inseriti e chiarissi ciò che desideri ottenere.
Questo eviterebbe a chi desidera aiutarti dover ricostruire una probabile struttura con il rischio di non centrare l'obiettivo.Giuseppe
Ho provato a ricreare i due file.
Il mio file origine ha una serie lunga di colonne, alcune delle quali voglio vengano copiate sul file destinazione. Il codice "capisce" l'ultima data compilata nel file origine, la confronta nel file destinazione e controlla quanti dati sono già stati copiati.
Procede alla copia dei valori.
Il mio problema è l'individuazione delle colonne da copiare. Ho al momento definito un array su codice ma se cambio posizione ad una colonna, mi si scombina tutto.
Vorrei che in un foglio appoggio (o sulla riga superiore alle intestazioni) potessi definire il matching tra le colonne come definito nel codice
arr_Orig = Array("DK", "DL", "DM", "DN", "E", "AP") ' <-- Origine
arr_Dest = Array("T", "U", "V", "W", "X", "Y") ' <-- Destinazione
ma rendendolo in qualche modo automatico (se il codice legge le intestazioni, posso spostare le colonne sia su origine che su destino senza problemi)
Allegati:
You must be logged in to view attached files.Buon pomeriggio, @danros;
ho cercato di analizzare il Codice VBA ma non sono riuscito ad attivare la Function LeggeUltimaDataDestinazione, devo ragionare meglio sui parametri:
ByRef rWsh As Worksheet, ByRef rRiga As Integer, ByRef rDataUlt As Date, ByVal strCella As String, vOffsetData.Molto interessante il "Filtro dinamico":
Non ne conoscevo l'esistenza e sto cercando di imparare come realizzarlo e come gestirlo.Buona serata.
Giuseppe
Buona giornata, @danros;
non voglio sconvolgerti la vita ma solo confrontarmi con te sul Codice VBA.Sono partito riscrivendo il Codice VBA.
Partendo dal File Origine avrei pensato di utilizzare un Array definito con:
- Numero di Date da valutare
- Campo intestazione
- Valore da
Fatto ciò pensavo di aprire il File Destinazione.
Confrontando Data e Campo intestazione registrerei il Valore.Questo comporta che non sarà possibile rinominare i Campi intestazione ma sarà possibile spostare i Campi a piacere sia nel File Origine che nel File Destinazione
Con l'auspicio di essere più concreto riporto il Codice VBA di acquisizione dei Dati.
`Option Explicit Option Compare Text Sub Test() Application.ScreenUpdating = False Dim NRc As Long, x As Long, NCl As Long, y As Long Dim RgX As Integer Dim Rcd() NCl = Cells(4, Columns.Count).End(xlToLeft).Column ' N° Colonne NRc = Range("B" & Rows.Count).End(xlUp).Row ' N° Record ReDim Rcd(NRc, 6, 6) For x = 5 To NRc If Cells(x, NCl).Value = "OK" Then RgX = x ' Prima Riga Exit For End If Next x For x = RgX To NRc If Cells(x, 2).Value >= Date Then Exit For Else For y = 2 To NCl Select Case Cells(4, y).Value Case "prodotta per dogane" ' 1) Rcd(x, 0, 0) = Cells(x, 2) ' Data Rcd(x, 1, 0) = Cells(4, y) ' Intestazione Rcd(x, 1, 1) = Cells(x, y) ' Valore Case "ATT+ per dogane" ' 2) Rcd(x, 0, 0) = Cells(x, 2) Rcd(x, 1, 0) = Cells(4, y) Rcd(x, 1, 1) = Cells(x, y) Case "ATT- per dogane" ' 3) Rcd(x, 0, 0) = Cells(x, 2) Rcd(x, 1, 0) = Cells(4, y) Rcd(x, 1, 1) = Cells(x, y) Case "Autoconsumata per dogane" ' 4) Rcd(x, 0, 0) = Cells(x, 2) Rcd(x, 1, 0) = Cells(4, y) Rcd(x, 1, 1) = Cells(x, y) Case "Totalizzatore Matricola [cnt4]" ' 5) Rcd(x, 0, 0) = Cells(x, 2) Rcd(x, 1, 0) = Cells(4, y) Rcd(x, 1, 1) = Cells(x, y) Case "Note" ' 6) Rcd(x, 0, 0) = Cells(x, 2) Rcd(x, 1, 0) = Cells(4, y) Rcd(x, 1, 1) = Cells(x, y) End Select Next y End If Next x Application.ScreenUpdating = True MsgBox "Aquisizione Dati completata." End Sub `
Nel caso in cui questo risulti accettabile per le tue esigenze potrei implementare il Codice VBA con:
- Apertura del File Destinazione
- Inserire i Valori nei relativi CampiCosa ne pensi?
Rimango a disposizione per eventuali ulteriori chiarimenti sulla struttura del Codice VBA.
Buon Lavoro.
Giuseppe
Ciao
l'idea non mi dispiace. Da quanto capisco legge le date nel foglio origine: vedo che si ferma se trova la stringa OK nella colonna "filtro", A me serve che controlli quando la colonna "Autoconsumata per dogane" in verde, ha un valore diverso da "". Diversamente potrei inserire una ennesima colonna con un campo certo che si aggiorna quando ci sono dati sulle altre.
Come controlla se ho già copiato i dati? Potrei eseguire la copia dei dati il 15/09 e poi ripetere la copia oggi 23. Oggi dovrà copiare solo i dati dal 16 al 23
Fammi capire: ReDim Rcd(NRc, 6, 6): presuppone che le colonne dei dati da copiare siano sempre 6? Questo significa che serve adattare l'ultimo numero in base al numero di colonne con dati da copiare. Sarebbe più fruibile se potessi definire in un foglio a parte le intestazioni di colonne che serve copiare. In questo modo il codice potrebbe essere sempre lo stesso ma potrei usarlo su vari foglio dove le colonne non sono mai le stesse.
La funzione Case "Totalizzatore Matricola [cnt4]" funziona anche nel caso in, ad esempio, cui prima di matricola avessi un avanzamento di riga? Alcune volte sono stati inseriti degli avanzamenti di riga in modo da rendere il testo leggibile. Se questo è un problema li posso rimuovere.
Inoltre: Le sequenze dei CASE, tipo la seguente, possono essere impostate random o servono con ordine preciso?
Case "Totalizzatore Matricola [cnt4]" ' 5)
Rcd(x, 0, 0) = Cells(x, 2)
Rcd(x, 1, 0) = Cells(4, y)
Rcd(x, 1, 1) = Cells(x, y)
Grazie per le info e anche per le idee.
Buon pomeriggio, @danros;
ovviamente il caricamento dei Dati può essere condizionato da "n" variabili, la cosa che mi sembrava interessante è che i Campi da considerre non sono vincolati alla posizione delle intestazioni sia nel File Origine che nel File Destinazione.
L'unico problema è la distanza; se potessimo parlare sono abbastanza sicuro che troveremmo molto rapidamente una strategia comune.
Le sequenze dei CASE sono impostate random, non serve un ordine preciso; il Codice scansione tutte le intestazioni presenti in Riga 4, confronta ogni intestazione con tutti i Case, quando trova una corrispondenza registra nell'Array dedicato i Dai relativi a:
- Data
- Intestazione del Campo
- Relativo Valore
Data e Intestazione Campo verranno poi verificati nel File Destinazione; quando trova una corrispondenza, se il Valore del Campo è vuoto, registra il Valore registrato nell'Array.Fai sapere come vuoi procedere; nel frattempo, per mia conoscenza personale, continuo a cercare di capire come costruire questa tipo di struttura:
che mi piace molto ma non ho mai avuto modo di utilizzare.
Buon Lavoro.
Giuseppe
Ciao Giuseppe
Scusa ma ho avuto accesso al web solo stamattina.
Il filtro applicato in realtà è più semplice di quello che pensi.
I dati sono in una tabella, che si porta dietro una serie di proprietà utili per definire filtri, o range di date oltre che formule ecc ecc
Ho creato una colonna "filtro" con una formula in base alla data =SE(BA643<OGGI()+$L$1;"V";SE(BA643>OGGI()+$O$1;"F";"Ok"))
Poi ho inserito il filtro.
Per la mia questione, il tuo codice funziona molto bene, lo testerò a breve ma mi manca sempre il come il tuo codice discrimina da dove partire. in sostanza nel mio esempio ho la colonna "Autoconsumata per dogane" che è il punto di partenza. Se trova dati sul file origine in questa colonna che non ci sono nel file destino, deve copiare
Buona giornata, @danros;
il Codice genera um Array di tutti i Record nei quali in Colonna "DO" è presente il valore "OK".
Quando temina la scansione, nello stesso Codice VBA è possibile:
- Aprire il File "Destinazione"
- Analizzare tutti i Record presenti nel File "Destinazione" con il Campo "Data" inserita negli Array
- Quando trova una corrispondenza e il Campo "Autoconsumata per dogane" vuoto copia il Record completoQuesta è solo una possibilità; in alternativa è possibile partire dal File "Destinazione", eseguire una scansione di tutti i Record, quando trova il Campo "Autoconsumata per dogane" vuoto copia il Record dal File "Origine" che corrisposnde alla stessa Data.
Credo che il Tempo di elaborazione sia più impegnativo ma si può fare.Fai sapere se hai problemi.
Buon Lavoro.
Giuseppe
il Codice genera um Array di tutti i Record nei quali in Colonna "DO" è presente il valore "OK".
Questo significa che si può beccare un array al di fuori del range di copia. Il filtro OK nel file origine mi serve per avere uno storico breve indietro nel tempo, mentre nel file destino serve per valutare quando le colleghe hanno trascritto nei registri manuali o nei portali sul web i dati che io gli ho passato.
Attualmente il mio codice legge in destino l'ultimo dato compilato nella colonna "Autoconsumata per dogane" e memorizza la data relativa. Poi copia da qui in poi fino a che trova dati sulla stessa colonna nel file origine.
Se io volessi sovrascrivere dei dati su destino, mi basta cancellare i dati nel file destino, nella colonna "Autoconsumata per dogane"
Detto questo ritengo sia sufficiente modificare il tuo codice affinchè controlli la colonna "Autoconsumata per dogane" e appena trova la cella vuota si fermi. Per quanto riguarda il numero di righe indietro nel tempo = La lunghezza dell'array si potrebbe impostare un range fisso (non capita mai che passino più di 30gg tra una elaborazione e l'altra). controllando poi su destino di scrivere solo i dati dove le celle sono vuote si dovrebbe sistemare.
Buona sera, @danros;
a proposito di:Detto questo ritengo sia sufficiente modificare il tuo codice affinchè controlli la colonna "Autoconsumata per dogane" e appena trova la cella vuota si fermi. Per quanto riguarda il numero di righe indietro nel tempo = La lunghezza dell'array si potrebbe impostare un range fisso (non capita mai che passino più di 30gg tra una elaborazione e l'altra). controllando poi su destino di scrivere solo i dati dove le celle sono vuote si dovrebbe sistemare.
questo significa che hai già modificato la struttura del Codice VBA oppure serve un ulteriore intervento?
Relativamente a:
Ho creato una colonna "filtro" con una formula in base alla data =SE(BA643<OGGI()+$L$1;"V";SE(BA643>OGGI()+$O$1;"F";"Ok"))
La Formula mi era chiara, quello che non capisco è come costruire la struttua:
Utilizzo molto raramente le Tabelle e non ne conosco tutte le proprietà.
Continuo a provare.
A disposizione.
Buona serata.
Giuseppe
-
AutoreArticoli