Ciao Red Mud,
Ho lanciato questo codice e ha fatto l'analisi di tutte le cartelle.
Tutto regolare!
Bene!
Ha elencato 61 volte un file presente nelle stessa cartella (la prima dell'estrazione).
Il file è sempre il solito...elencato 61 volte....thumbs.db
Questo mi sorprende molto, in quanto l'istruzione
If oFile.Name Like "*.xls*" Then
dovrebbe assicurarsi che solo i file con un'estensione che comprende .xls siano elaborati sul primo foglio riepilogativo. Sei sicuro che in realtà il file
thumbs.db non sia elencato sul secondo foglio ripielogativo AltriFile? Ho creato quest'ultimo foglio al fine di elencare tutti i file di tipo non Excel. A questo proposito, le istruzioni
rilevanti sono:
If oFile.Name Like "*.xls*" Then
[CUT]
Else
i = i + 1
ReDim Preserve arrAltriFile(1 To i)
arrAltriFile(i) = oFile.Path
End If
Se il file thumbs.db è stato elencato 61 volte sul foglio AltriFile, questo suggerirebbe che questo file esiste in 61 sottodirectory.
TI invio il file in pvt.
Purtroppo, questo non è utile: sarebbe invece necessario inviare una copia di tutte le 61 sottodirectory e anche i piu' di 1100 file! Ti prego di non farlo!
Come posso eliminarlo definitivamente?
Non lo vedo, nella directory.
Non sono riuscito ad eliminarlo nemmeno con cmd.exe.
Al fine anche di eliminare ogni istanza di un file nominato thumbs.db in qualsiasi delle sottodirectory di interesse, prova la seguente versione del codice:
'=========>>
Option Explicit
'--------->>
Public Sub Tester()
Dim FSO As Object
Dim oFile As Object
Dim oFiles As Object
Dim oFolder As Object
Dim oSubFolder As Object
Dim srcWB As Workbook, destWB As Workbook
Dim srcSH As Worksheet, destSH As Worksheet, aSH As Worksheet
Dim Rng As Range, rCell As Range
Dim arrExclude As Variant, arrHeaders As Variant
Dim arrAltriFile() As Variant
Dim iRow As Long
Dim i As Long, j As Long, k As Long
Dim myFile As String, myFolder As String
Dim Res As Variant
Dim dDate As Date
Dim sPrompt As String, iButtons As Long, sTitle As String
Const sAddress = "F2,K2,C4,H4,C6,H6,E8,I7,I8,J8,L8," _
& "E9,I9,E10,E11,E12,E13,I14,J15,E16,J17,J18" '<<==== Modifica
Const sFolder As String = "X:\SCHEDE PREZZO"
Const sHeaders As String = "CARTELLA ORIGINE,FILE ORIGINE," _
& "ULTIMA MODIFICA,FOGLIO DI ORIGINE,CLIENTE,DATA," _
& "DESCRIZIONE,CODICE,DIMENSIONE,REVISIONE DISEGNO," _
& "PESO BARRA,BARRA EXT,MISURA EXT,BARRA INT,MISURA INT," _
& "LUNGH SPEZZ,MATERIALE,BASE METALLO,EXTRA MISURA," _
& "TOTALE METALLO,VALORE SFRIDO,PESO OCCORRENTE," _
& "COSTO MATERIALE,PESO FINITO,RECUPERO SFRIDO," _
& "COSTO MATERIA PRIMA" '<<==== Modifica
Set destWB = ThisWorkbook
Set destSH = destWB.Sheets(1)
iRow = 1
arrExclude = VBA.Array("Calcolo peso", "Forme")
arrHeaders = Split(sHeaders, ",")
With destSH.Range("A1").Resize(1, UBound(arrHeaders) + 1)
.Value = arrHeaders
.Font.Bold = True
.Font.Underline = True
End With
On Error GoTo XIT
Application.ScreenUpdating = False
Set FSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(sFolder)
For Each oSubFolder In oFolder.SubFolders
Set oFiles = oSubFolder.Files
For Each oFile In oFiles
If oFile.Name Like "*.xls*" Then
dDate = oFile.DateLastModified
Application.StatusBar = "Processing il file " & oFile.Path
Set srcWB = Workbooks.Open(oFile)
With srcWB
For Each srcSH In .Worksheets
With srcSH
j = 1
Res = Application.Match(.Name, arrExclude, 0)
If IsError(Res) Then
iRow = iRow + 1
With destSH
.Cells(iRow, "A").Value = oSubFolder.Path
.Cells(iRow, "B").Value = oFile.Path
.Cells(iRow, "C").Value = dDate
.Cells(iRow, "D").Value = srcSH.Name
Set Rng = srcSH.Range(sAddress)
For Each rCell In Rng.Cells
j = j + 1
.Cells(iRow, j + 3).Value = rCell.Value
Next rCell
End With
End If
End With
Next srcSH
.Close savechanges:=False
End With
Else
If UCase(oFile.Name) Like UCase("thumbs.db") Then
With oFile
.Attributes = 0
Kill oFile
End With
Else
i = i + 1
ReDim Preserve arrAltriFile(1 To i)
arrAltriFile(i) = oFile.Path
End If
End If
Next oFile
Next oSubFolder
destSH.UsedRange.EntireColumn.AutoFit
If CBool(i) Then
With destWB
On Error Resume Next
Set aSH = .Sheets("AltriFile")
On Error GoTo XIT
If Not aSH Is Nothing Then
aSH.Cells.ClearContents
Else
Set aSH = .Sheets.Add(after:=.Sheets(1))
End If
End With
With aSH
.Name = "AltriFile"
.Range("A2").Resize(i).Value = arrAltriFile
End With
End If
XIT:
With Application
.ScreenUpdating = True
.StatusBar = False
End With
If Err.Number = 0 Then
sPrompt = "La procedura è stata completata senza alcun problema"
iButtons = 64
sTitle = "Finito"
Else
sPrompt = "Errore " _
& Err.Number _
& " (" _
& Err.Description _
& ") nella routine: Tester"
iButtons = 16
sTitle = "ERRORE"
End If
Call MsgBox(sPrompt, iButtons, sTitle)
End Sub
'<<=========
Prima di eseguire questo codice, verifica che i file thumbs.db non sono necessari o importanti! In caso di dubbio, crea una
copia di backup!
Nel codice precedente, le nuove istruzioni sono evidenziate in grassetto.
===
Regards,
Norman
![](data:image/svg+xml, %3Csvg xmlns='http://www.w3.org/2000/svg' height='64' class='font-weight-bold' style='font: 600 30.11764705882353px "SegoeUI", Arial' width='64'%3E%3Ccircle fill='hsl(128, 8%, 22%)' cx='32' cy='32' r='32' /%3E%3Ctext x='50%25' y='55%25' dominant-baseline='middle' text-anchor='middle' fill='%23FFF' %3EA%3C/text%3E%3C/svg%3E)
