Aggiornamento automatico serie di valori

Anonimo

Buongiorno, ho una piccola necessità, concettualmente facile, ma non trovo soluzione.

Quotidianamente ricevo un report vendite di un centinaio di prodotti, un file Excel che ha sempre lo stesso nome, stesso layout delle celle, ma cambiano ovviamente i valori.

È possibile creare un secondo file con lo storico di ogni giorno, separato per ogni prodotto, prendendo ogni giorno il valore della stessa cella dal primo file, e creando quindi una serie di dati nel secondo file, in modo da poter poi elaborare un grafico?

Evitando di doverlo fare a mano, si intende..

in pratica è un vettore di dati in cui ogni dato è preso sempre dalla stessa cella del file di provenienza, e crea così una serie, giorno dopo giorno

Domanda bloccata. Questa domanda è stata eseguita dalla community del supporto tecnico Microsoft. È possibile votare se è utile, ma non è possibile aggiungere commenti o risposte o seguire la domanda.

0 commenti

11 risposte

Anonimo

2021-09-15T21:32:36+00:00

Ciao Marco,

l'ho provato ma non riesco a farlo funzionare.

creo un file xlm, con il codice che mi hai dato, modificando nome file/percorso/foglio.

l'errore che mi genera è nella parte di codice:

...

With srcSH

iRow = LastRow(srcSH, .Columns("A:B"))
...

(errore su LastRow)

"errore di compilazione: Sub o function non definita"

non c'è modo di poter indicare anche la cella del dato che deve copiare nel nuovo file (da mettere dopo il valore preso il giorno precedente)?

Il tuo errore suggerisce fortemente che non hai copiato il codice per la mia funzione LastRow in un modulo di codice standard. In questo modulo di codice, dovrebbe apparire tutto il codice seguente, incluso il codice della funzione LastRow che è evidenziato in rosso qui di seguito:

'========>>

Option Explicit

'-------->>

Public Sub Tester()

Dim srcWB As Workbook, destWB As Workbook

Dim srcSH As Worksheet, destSH As Worksheet

Dim srcRng As Range, destRng As Range

Dim arrDati() As Variant, arrIn As Variant, arrNuoviProdotti() As Variant, arrTemp As Variant

Dim Res As Variant

Dim oTable As ListObject

Dim sStr As String, sPath As String

Dim sFilename As String, sProdotto As String

Dim iFileDate As Long

Dim i As Long, j As Long, iCtr As Long

Dim iCol As Long, jCol As Long

Dim iRow As Long, jRow As Long

Const sFile_Vendite_Giornaliere As String = "Vendite.xlsx" '<<=== Modifica

Const sFoglio_Sorgente As String = "Foglio1" '<<=== Modifica

Const sPercorso As String = "C:\Users\Marco\Documents" '<<=== Modifica

sStr = Application.PathSeparator

If Right(sPercorso, 1) <> sStr Then

sPath = sPercorso & sStr

Else

sPath = sPercorso

End If

On Error GoTo XIT

Application.ScreenUpdating = False

sFilename = sPath & sFile_Vendite_Giornaliere

Set srcWB = Workbooks.Open(sFilename)

Set destWB = ThisWorkbook

Set srcSH = srcWB.Sheets(sFoglio_Sorgente)

With srcSH

iRow = LastRow(srcSH, .Columns("A:B"))

Set srcRng = .Range("A:B").Resize(iRow)

arrIn = srcRng.Value

iFileDate = Int(FileDateTime(sFilename))

.Parent.Close SaveChanges:=False

End With

Set destWB = ThisWorkbook

Set destSH = destWB.Sheets(1)

With destSH

jRow = LastRow(srcSH, .Columns("A"))

Set destRng = .Range("A1").CurrentRegion.Resize(jRow)

arrDati = destRng.Value2

End With

ReDim Preserve arrDati(1 To UBound(arrDati), 1 To UBound(arrDati, 2) + 1)

iCol = UBound(arrDati, 2)

arrDati(1, iCol) = iFileDate

For i = 2 To UBound(arrIn)

sProdotto = arrIn(i, 1)

arrTemp =Application.Index(arrDati, 0, 1)

Res = Application.Match(sProdotto, arrTemp, 0)

If Not IsError(Res) Then

arrDati(Res, iCol) = arrIn(i, 2)

Else

'\ Nuovo prodotto!

iCtr = iCtr + 1

ReDim Preserve arrNuoviProdotti(1 To iCol, 1 To iCtr)

arrNuoviProdotti(1, iCtr) = arrIn(i, 1)

arrNuoviProdotti(iCol, iCtr) = arrIn(i, 2)

End If

Next i

With destRng

With .Cells(1).Resize(UBound(arrDati), iCol)

.Value = arrDati

.Rows(1).NumberFormat = "dd/mm/yy"

End With

If CBool(iCtr) Then

'\ Nuovi prodotti trovati

.Cells(UBound(arrDati) + 1, 1).Resize(iCtr, iCol).Value = Application.Transpose(arrNuoviProdotti)

End If

Set oTable = .Parent.ListObjects.Add(xlSrcRange, .Cells(1).Resize(UBound(arrDati), iCol), , xlYes)

With oTable

.Name = "Tabella_Vendite"

.DataBodyRange.Offset(, 1).HorizontalAlignment = xlCenter

End With

End With

XIT:

Application.ScreenUpdating = True

End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _

Optional Rng As Range, _

Optional minRow As Long = 1)

If Rng Is Nothing Then

Set Rng = SH.Cells

End If

On Error Resume Next

LastRow = Rng.Find(What:="*", _

After:=Rng.Cells(1), _

Lookat:=xlPart, _

LookIn:=xlFormulas, _

SearchOrder:=xlByRows, _

SearchDirection:=xlPrevious, _

MatchCase:=False).Row

On Error GoTo 0

If LastRow < minRow Then

LastRow = minRow

End If

End Function

'<<========

Anche se mi stupirebbe se l'errore da te segnalato si manifestasse in presenza del codice evidenziato in rosso, se dovessi avere ancora un problema ti chiederei gentilmente di caricare il file problematico, privo di dati sensibili.

Per caricare il file su Microsoft OneDrive, vedi:

Condividere file e cartelle di OneDrive

Per caricare il file su DropBox, vedi:

Come faccio a condividere file e cartelle in Dropbox?

===

Regards,

Norman
La risposta è stata utile?

0 commenti Nessun commento
Anonimo

2021-09-15T13:44:30+00:00
l'ho provato ma non riesco a farlo funzionare.

creo un file xlm, con il codice che mi hai dato, modificando nome file/percorso/foglio.

l'errore che mi genera è nella parte di codice:

...

With srcSH
```
    iRow = **LastRow**(srcSH, .Columns("A:B"))  
```
...

(errore su LastRow)

"errore di compilazione: Sub o function non definita"

non c'è modo di poter indicare anche la cella del dato che deve copiare nel nuovo file (da mettere dopo il valore preso il giorno precedente)?
La risposta è stata utile?

0 commenti Nessun commento

Anonimo

Ciao Marco,

Per garantire la corretta attribuzione delle date dei file, per allineare i dati scaricati e per memorizzare questi dati in una tabella Excel, provare a sostituire il codice precedente con la seguente versione:

'========>>

Option Explicit

'-------->>

Public Sub Tester()

Dim srcWB As Workbook, destWB As Workbook 

Dim srcSH As Worksheet, destSH As Worksheet 

Dim srcRng As Range, destRng As Range 

Dim arrDati() As Variant, arrIn As Variant, arrNuoviProdotti() As Variant, arrTemp As Variant 

Dim Res As Variant 

Dim oTable As ListObject 

Dim sStr As String, sPath As String 

Dim sFilename As String, sProdotto As String 

Dim iFileDate As Long 

Dim i As Long, j As Long, iCtr As Long 

Dim iCol As Long, jCol As Long 

Dim iRow As Long, jRow As Long 

Const sFile\_Vendite\_Giornaliere As String = **"Vendite.xlsx"                 '&lt;&lt;=== Modifica**

Const sFoglio\_Sorgente As String = **"Foglio1"                                     '&lt;&lt;=== Modifica**

Const sPercorso As String = **"C:\Users\Marco\Documents\"             '&lt;&lt;=== Modifica**

sStr = Application.PathSeparator 

If Right(sPercorso, 1) &lt;&gt; sStr Then 

    sPath = sPercorso & sStr 

Else 

    sPath = sPercorso 

End If 

On Error GoTo XIT 

Application.ScreenUpdating = False 

sFilename = sPath & sFile\_Vendite\_Giornaliere 

Set srcWB = Workbooks.Open(sFilename) 

Set destWB = ThisWorkbook 

Set srcSH = srcWB.Sheets(sFoglio\_Sorgente) 

With srcSH 

    iRow = LastRow(srcSH, .Columns("A:B")) 

    Set srcRng = .Range("A:B").Resize(iRow) 

    arrIn = srcRng.Value 

    iFileDate = Int(FileDateTime(sFilename)) 

    .Parent.Close SaveChanges:=False 

End With 

Set destWB = ThisWorkbook 

Set destSH = destWB.Sheets(1) 

With destSH 

    jRow = LastRow(srcSH, .Columns("A")) 

    Set destRng = .Range("A1").CurrentRegion.Resize(jRow) 

    arrDati = destRng.Value2 

End With 

ReDim Preserve arrDati(1 To UBound(arrDati), 1 To UBound(arrDati, 2) + 1) 

iCol = UBound(arrDati, 2) 

arrDati(1, iCol) = iFileDate 

For i = 2 To UBound(arrIn) 

    sProdotto = arrIn(i, 1) 

    arrTemp =Application.Index(arrDati, 0, 1)

    Res = Application.Match(sProdotto, arrTemp, 0) 

    If Not IsError(Res) Then 

        arrDati(Res, iCol) = arrIn(i, 2) 

    Else 

        '\\ Nuovo prodotto! 

        iCtr = iCtr + 1 

        ReDim Preserve arrNuoviProdotti(1 To iCol, 1 To iCtr) 

        arrNuoviProdotti(1, iCtr) = arrIn(i, 1) 

        arrNuoviProdotti(iCol, iCtr) = arrIn(i, 2) 

    End If 

Next i 

With destRng 

    With .Cells(1).Resize(UBound(arrDati), iCol) 

        .Value = arrDati 

        .Rows(1).NumberFormat = "dd/mm/yy" 

    End With 

    If CBool(iCtr) Then 

        '\\ Nuovi prodotti trovati 

        .Cells(UBound(arrDati) + 1, 1).Resize(iCtr, iCol).Value = Application.Transpose(arrNuoviProdotti) 

    End If 

    Set oTable = .Parent.ListObjects.Add(xlSrcRange, .Cells(1).Resize(UBound(arrDati), iCol), , xlYes) 

    With oTable 

        .Name = "Tabella\_Vendite" 

        .DataBodyRange.Offset(, 1).HorizontalAlignment = xlCenter 

    End With 

End With

XIT:

Application.ScreenUpdating = True

End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _

Optional Rng As Range, \_ 

Optional minRow As Long = 1) 

If Rng Is Nothing Then 

    Set Rng = SH.Cells 

End If 

On Error Resume Next 

LastRow = Rng.Find(What:="\*", \_ 

    After:=Rng.Cells(1), \_ 

    Lookat:=xlPart, \_ 

    LookIn:=xlFormulas, \_ 

    SearchOrder:=xlByRows, \_ 

    SearchDirection:=xlPrevious, \_ 

    MatchCase:=False).Row 

On Error GoTo 0 

If LastRow &lt; minRow Then 

    LastRow = minRow 

End If

End Function

'<<========

===

Regards,

Norman

0 commenti

Anonimo

2021-09-10T15:45:02+00:00

grazie dell'aiuto e per la celere risposta! ci metto le mani prima possibile e faccio sapere!
La risposta è stata utile?

0 commenti Nessun commento

Anonimo

Ciao Marco,

ho una piccola necessità, concettualmente facile, ma non trovo soluzione.

Quotidianamente ricevo un report vendite di un centinaio di prodotti, un file Excel che ha sempre lo stesso nome, stesso layout delle celle, ma cambiano ovviamente i valori.

È possibile creare un secondo file con lo storico di ogni giorno, separato per ogni prodotto, prendendo ogni giorno il valore della stessa cella dal primo file, e creando quindi una serie di dati nel secondo file, in modo da poter poi elaborare un grafico?

Evitando di doverlo fare a mano, si intende..

in pratica è un vettore di dati in cui ogni dato è preso sempre dalla stessa cella del file di provenienza, e crea così una serie, giorno dopo giorno

Prova qualcosa del genere:

In un nuovo file, immetti un elenco dei prodotti nella colonna A del primo foglio, iniziando l'elenco nella cella A2
Alt+F11 per aprire l'editor di VBA
Alt+IM per inserire un nuovo modulo di codice
Nel nuovo modulo vuoto, incolla il seguente codice:

'========>>

Option Explicit

'-------->>

Public Sub Tester()

Dim srcWB As Workbook, destWB As Workbook 

Dim srcSH As Worksheet, destSH As Worksheet 

Dim srcRng As Range, destRng As Range 

Dim arrDati() As Variant, arrIn As Variant, arrNuoviProdotti() As Variant, arrTemp As Variant 

Dim Res As Variant 

Dim sStr As String, sPath As String 

Dim sFilename As String, sProdotto As String 

Dim iFileDate As Long 

Dim i As Long, j As Long, iCtr As Long 

Dim iCol As Long, jCol As Long 

Dim iRow As Long, jRow As Long 

Const sFile\_Vendite\_Giornaliere As String = **"Vendite.xlsx"             '&lt;&lt;=== Modifica** 

Const sFoglio\_Sorgente As String = **"Foglio1"                                 '&lt;&lt;=== Modifica** 

Const sPercorso As String = **"C:\Users\Marco\Documents\"         '&lt;&lt;=== Modifica** 

sStr = Application.PathSeparator 

If Right(sPercorso, 1) &lt;&gt; sStr Then 

    sPath = sPercorso & sStr 

Else 

    sPath = sPercorso 

End If 

On Error GoTo XIT 

Application.ScreenUpdating = False 

sFilename = sPath & sFile\_Vendite\_Giornaliere 

Set srcWB = Workbooks.Open(sFilename) 

Set destWB = ThisWorkbook 

Set srcSH = srcWB.Sheets(sFoglio\_Sorgente) 

With srcSH 

    iRow = LastRow(srcSH, .Columns("A:B")) 

    Set srcRng = .Range("A:B").Resize(iRow) 

    arrIn = srcRng.Value 

    iFileDate = CLng(FileDateTime(sFilename)) 

    .Parent.Close SaveChanges:=False 

End With 

Set destWB = ThisWorkbook 

Set destSH = destWB.Sheets(1) 

With destSH 

    jRow = LastRow(srcSH, .Columns("A")) 

    Set destRng = .Range("A1").CurrentRegion.Resize(jRow) 

    arrDati = destRng.Value 

End With 

ReDim Preserve arrDati(1 To UBound(arrDati), 1 To UBound(arrDati, 2) + 1) 

iCol = UBound(arrDati, 2) 

arrDati(1, iCol) = iFileDate 

For i = 2 To UBound(arrIn) 

    sProdotto = arrIn(i, 1) 

    arrTemp = Application.Transpose(Application.Index(arrDati, 0, 1)) 

    Res = Application.Match(sProdotto, arrTemp, 0) 

    If Not IsError(Res) Then 

        arrDati(Res, iCol) = arrIn(i, 2) 

    Else 

        '\\ Nuovo prodotto! 

        iCtr = iCtr + 1 

        ReDim Preserve arrNuoviProdotti(1 To iCol, 1 To iCtr) 

        arrNuoviProdotti(1, iCtr) = arrIn(i, 1) 

        arrNuoviProdotti(iCol, iCtr) = arrIn(i, 2) 

    End If 

Next i 

With destRng 

    .Cells(1).Resize(UBound(arrDati), iCol).Value = arrDati 

    .Cells(1, iCol).NumberFormat = "dd/mm/yy" 

    If CBool(iCtr) Then 

        '\\ Nuovi prodotti trovati 

        .Cells(UBound(arrDati) + 1, 1).Resize(iCtr, iCol).Value = Application.Transpose(arrNuoviProdotti) 

    End If 

End With

XIT:

Application.ScreenUpdating = True

End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _

Optional Rng As Range, \_ 

Optional minRow As Long = 1) 

If Rng Is Nothing Then 

    Set Rng = SH.Cells 

End If 

On Error Resume Next 

LastRow = Rng.Find(What:="\*", \_ 

    After:=Rng.Cells(1), \_ 

    Lookat:=xlPart, \_ 

    LookIn:=xlFormulas, \_ 

    SearchOrder:=xlByRows, \_ 

    SearchDirection:=xlPrevious, \_ 

    MatchCase:=False).Row 

On Error GoTo 0 

If LastRow &lt; minRow Then 

    LastRow = minRow 

End If

End Function

'<<========

Alt+Q per chiudere l'editor di VBA e tornare a Excel
Salva il file con l’estensione xlsm
Ogni giorno, Alt+F8 per aprire la finestra di gestione delle macro
Seleziona Tester
Esegui

===

Regards,

Norman

0 commenti

Condividi tramite

Aggiornamento automatico serie di valori

11 risposte