Copia dati tra fogli in base a data e a valore di riferimento

[danrosPartecipante danros]

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

[GiuseppeMNPartecipante GiuseppeMN Karma: 19 pts]

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

[danrosPartecipante danros]

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.

[GiuseppeMNPartecipante GiuseppeMN Karma: 19 pts]

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

[GiuseppeMNPartecipante GiuseppeMN Karma: 19 pts]

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 Campi

Cosa ne pensi?

 

Rimango a disposizione per eventuali ulteriori chiarimenti sulla struttura del Codice VBA.

Buon Lavoro.

Giuseppe

[danrosPartecipante danros]

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.

 

 

[GiuseppeMNPartecipante GiuseppeMN Karma: 19 pts]

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

[danrosPartecipante danros]

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

 

[GiuseppeMNPartecipante GiuseppeMN Karma: 19 pts]

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 completo

Questa è 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

[danrosPartecipante danros]

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.

[GiuseppeMNPartecipante GiuseppeMN Karma: 19 pts]

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

[Autore]

Articoli