sincronizzare fogli excel

Question

Buongiorno a tutti, ho una necessità di questo tipo:

ho un foglio excel che deve aggiornare dei valori in un altro foglio excel.

In particolare nel foglio di destinazione i campi da compilare sono sempre gli stessi, mentre il foglio in cui prendere questi dati è fatto a righe, per cui una volta finita la prima riga occorre passare alla seconda con un nuovo file di destinazione.

Capisco che è un po contorto, ma ringrazio in anticipo chi mi può dare una mano.

Grazie

Answer 1

...

Di seguito il link:

https://onedrive.live.com/?lc=1040&mkt=it-IT#cid=F1EEE4B81912029A&id=F1EEE4B81912029A%21103

Grazie ancora

Speriamo di essere arrivati al capolinea ...

Oltre alle ultime modifiche, per le quali ti invito a controllare se i range copiati sono corretti, ho anche recepito la prima parte, calcolando un valore casuale intermedio tra i due pk (sempre che esitano dei valori nelle rispettive colonne).

Visto e considerato che i due tipi di file hanno lo stesso nome ho pensato di scriverli in due cartelle diverse, ...\File1\ e ...\File2\ che devi creare tu prima dell'esecuzione (pena errore) e i cui nomi possono essere modificati nella prima prima parte del codice.

Riepilogando, i file origine, 1.xlsx, 2.xlsx,, 3.xlsx, devono trovarsi nella stessa cartella (come prima) in aggiunta questa cartella deve contenere anche le due sub-cartelle File1 e File2.

---

Sub sbrugola()

Dim wbTarget1 As Workbook, wbTarget2 As Workbook, wbTarget3 As Workbook, wbEmbedded As Workbook

Dim wsSource As Worksheet, wsTarget1 As Worksheet, wsTarget2 As Worksheet, wsTarget3 As Worksheet

Dim rCel As Range

Dim lHeaderRow As Long, lRow As Long

Dim lo As Double, hi As Double

Dim sTargetFolder As String, sTargetFile As String, sTargetFolder1 As String, sTargetFolder2 As String

  On Error GoTo Uffa

  With Application

     .ScreenUpdating = False

     .Calculation = xlCalculationManual

     .EnableEvents = False

     .DisplayAlerts = False

   End With

  '--- set up your data here -------------------

  lHeaderRow = 9                                                    ' riga testata

  sTargetFolder = ThisWorkbook.Path & ""                           ' cartella sorgente

  sTargetFolder1 = sTargetFolder & "File1"                         ' cartella destinazione file 1

  sTargetFolder2 = sTargetFolder & "File2"                         ' cartella destinazione file 2

  Set wsSource = ThisWorkbook.Worksheets("Lotto 0L")

  Set wbTarget1 = Workbooks.Open(sTargetFolder & "1.xlsx", , True)   ' template file 1

  Set wsTarget1 = wbTarget1.Worksheets(1)

  Set wbTarget2 = Workbooks.Open(sTargetFolder & "2.xlsx", , True)   ' template file 2

  Set wsTarget2 = wbTarget2.Worksheets("61114.02")

  Set wbTarget3 = Workbooks.Open(sTargetFolder & "3.xlsx", , True)   ' template file 3

  Set wsTarget3 = wbTarget3.Worksheets(1)

  '----------------------------------------------

  With wsSource

    For Each rCel In .Cells(lHeaderRow, "b").CurrentRegion.SpecialCells(xlCellTypeVisible).EntireRow

      lRow = rCel.Row

      Application.StatusBar = "Riga in elaborazione: " & lRow

      If lRow > lHeaderRow Then

        'If .Cells(lRow, "p").Value Like "*1" Then

        If Trim(.Cells(lRow, "p").Value) = "FILE 1" Then

          wsTarget1.Range("c4").Value = .Cells(lRow, "d").Value

          wsTarget1.Range("c5").Value = .Cells(lRow, "o").Value

          wsTarget1.Range("i3").Value = .Cells(lRow, "j").Value & .Cells(lRow, "k").Value

          wsTarget1.Range("i5").Value = .Cells(lRow, "c").Value

          wsTarget1.Range("h7").Value = .Cells(lRow, "q").Value

          wsTarget1.Range("l7").Value = .Cells(lRow, "r").Value

          wsTarget1.Range("d11").Value = .Cells(lRow, "u").Value

          wsTarget1.Range("c13").Value = .Cells(lRow, "h").Value

          wsTarget1.Range("i4").Value = .Cells(lRow, "b").Value

          '--- valore casuale intermedio

          If Len(.Cells(lRow, "f").Value) And Len(.Cells(lRow, "g").Value) Then

            lo = CDbl(Replace(.Cells(lRow, "f").Value, "+", ","))

            hi = CDbl(Replace(.Cells(lRow, "g").Value, "+", ","))

            wsTarget1.Range("d12").Value = Replace(Format(Rnd * (hi - lo) + lo, "#.000"), ",", "+")

          End If

          '--- ricalcola il file 3 e copia la tabella

          wsTarget3.Calculate

          wsTarget1.Range("b16:e30").Value = wsTarget3.Range("b16:e30").Value

          sTargetFile = sTargetFolder1 & .Cells(lRow, "q").Value & ".xlsx"

          wbTarget1.SaveAs sTargetFile, xlWorkbookDefault

        End If

        If Trim(.Cells(lRow, "p").Value) = "FILE 2" Then

          wsTarget2.Range("n9").Value = .Cells(lRow, "b").Value

          wsTarget2.Range("n10").Value = .Cells(lRow, "c").Value

          wsTarget2.Range("f11").Value = .Cells(lRow, "h").Value & .Cells(lRow, "k").Value

          wsTarget2.Range("n11").Value = .Cells(lRow, "k").Value

          wsTarget2.Range("f10").Value = .Cells(lRow, "o").Value

          wsTarget2.Range("i13").Value = .Cells(lRow, "q").Value

          wsTarget2.Range("l13").Value = .Cells(lRow, "r").Value

          '--- change embedded data

          With wsTarget2.Shapes(1)

            .OLEFormat.Activate

            Set wbEmbedded = .OLEFormat.Object.Object

            wbEmbedded.Sheets(1).Range("e30:e32").Value = wsTarget1.Range("e28:e30").Value

          End With

          wbEmbedded.Close

          sTargetFile = sTargetFolder2 & .Cells(lRow, "q").Value & ".xlsx"

          wbTarget2.SaveAs sTargetFile, xlWorkbookDefault

        End If

      End If

    Next

  End With

ExitHere:

  On Error Resume Next

  wbTarget1.Close False

  wbTarget2.Close False

  wbTarget3.Close False

  Set rCel = Nothing

  Set wsSource = Nothing:   Set wsTarget1 = Nothing:  Set wsTarget2 = Nothing:  Set wsTarget3 = Nothing

  Set wbEmbedded = Nothing: Set wbTarget1 = Nothing:  Set wbTarget2 = Nothing:  Set wbTarget3 = Nothing

  With Application

     .Calculation = xlCalculationAutomatic

     .ScreenUpdating = True

     .EnableEvents = True

     .DisplayAlerts = True

     .StatusBar = False

   End With

   Exit Sub

Uffa:

   Call MsgBox("Ohibò, si è verificato il seguente errore: " & vbNewLine & _

               CStr(Err.Number) & ": " & Err.Description & vbNewLine & vbNewLine & _

               "Riga in elaborazione: " & lRow, _

               vbCritical + vbOKOnly, "Error message")

   Resume ExitHere

End Sub

---

Answer 2

Grazie per le risposte, ho caricato a questo link

https://onedrive.live.com/?cid=F1EEE4B81912029A&id=F1EEE4B81912029A!103

i file in onedrive come richiesto.

Il file origine è strutturato a riga, cioè ogni riga contiene i dati che servono a compilare il file chiamato 1. Bisogna considerare che le righe da tenere in considerazione sono alternate ovvero, facendo riferimento alla colonna P del file origine bisogna considerare solo le righe con riferimento FILE1 scartando quelle con l'indicazione FILE2. I dati da utilizzare nel file origine sono:

colonna D (WBS) deve essere riportata nel file 1 nella cella C4

colonna O (STRATO) nella cella C5 del file 1

colonne J e K (concatenate) nella cella I4 del file 1

colonna C (data) deve essere riportata nella cella I5 del file 1

colonna B (prot) in cella H7 del file 1

colonna U (provenienza materiale) in cella D11 del file 1

colonne F e G se presente (da pk a pk) prendere un valore intermedio e metterlo in D12 del file 1

Infine salvare il file con nome che si trova nella colonna Q

Grazie ancora

Answer 3

Buongiorno a tutti, ho una necessità di questo tipo:

<cut>

Grazie

Capito poco.

File 1. Scrivo i dati. In quale foglio? Su quali colonne? Su una o più righe? E quali righe?

Altri Files. A loro invio i dati. A quali fogli? In quali colonne? E dove, dalla prima riga vuota?

E, nel caso debba inviare dati a più File, nel foglio del File 1 dove trovo il nome del File al quale inviare i dati?

Grazie.

Answer 4

Ciao sbrugola,

Avrei dovuto aggiungere: sostituisci/camuffa i dati sensibili!

===

Regards,

Norman

Answer 5

Ciao sbrugola,

Al fine di permetterci di aiutarti, vorrei suggerire che carichi un esempio del foglio Dati su OneDrive - una decina di righe dovrebbero essere sufficienti. Mostra anche i risultati desiderati per questi dati. 

Incolla il link al file in una risposta qui.

===

Regards,

Norman