- Codice: Seleziona tutto
Dim Riep As Object, FLNew As Object
Dim FlNewName As String
Dim I As Integer, Rgh As Integer, CL As Integer
Sub Controlla_redvin()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
'Eliminazione precedente file testo e poi creazione nuovo file testo
Dim FDStamp As Date
On Error Resume Next
Kill "C:\pippo123.txt"
Shell ("c:\pippo.bat")
Application.Wait (Now + TimeValue("0:00:05"))
Attesa:
FDStamp = FileDateTime("C:\pippo123.txt")
If IsEmpty(FDStamp) Then GoTo Attesa
If DateDiff("s", FDStamp, Now) < 20 Then GoTo Attesa
On Error GoTo 0
Columns("A:I").Select
Selection.ClearContents 'Cancella dati in foglio riepilogo
'Selection.QueryTable.Delete
Range("A2").Select
'Importa dati da file pippo123.txt
With ActiveSheet.QueryTables.Add(Connection:="TEXT;C:\pippo123.txt", _
Destination:=Range("A2"))
.Name = "pippo123"
.FieldNames = True
.PreserveFormatting = True
.RefreshStyle = xlInsertDeleteCells
.SaveData = True
.AdjustColumnWidth = True
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlFixedWidth
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileTabDelimiter = True
.TextFileColumnDataTypes = Array(1, 1)
.TextFileFixedColumnWidths = Array(5)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft 'Elimina 1ª colonna creata
Range("A1").Select
'Elimina da foglio riepilogo file finiti
Rgh = 2
While Cells(Rgh, 1) <> ""
If Right(Cells(Rgh, 1), 10) = "finito.xls" Then
Rows(Rgh).Delete
Else
Rgh = Rgh + 1
End If
Wend
Columns("A:A").EntireColumn.AutoFit
Range("A1") = "File": Range("B1,D1,F1,H1") = "Mese": Range("C1,E1,G1,I1") = "Valore"
Range("A1:I1").Select
Selection.HorizontalAlignment = xlCenter
Selection.Font.Bold = True
'Controlla file
Set Riep = Workbooks("Riepilogo (redvin).xls").Worksheets("Riepilogo")
Rgh = 2
While Riep.Cells(Rgh, 1) <> ""
Workbooks.Open Filename:=Riep.Cells(Rgh, 1).Text
FlNewName = ActiveWorkbook.Name
CL = 2
For I = 1 To Worksheets.Count
If Workbooks(FlNewName).Worksheets(I).Name = "Gennaio" Or Workbooks(FlNewName).Worksheets(I).Name = "Febbraio" _
Or Workbooks(FlNewName).Worksheets(I).Name = "Marzo" Or Workbooks(FlNewName).Worksheets(I).Name = "Aprile" Then
Workbooks(FlNewName).Worksheets(I).Select
If Range("J13") Or Range("J14") <> 0 Then
Riep.Cells(Rgh, CL) = Workbooks(FlNewName).Worksheets(I).Name
Riep.Cells(Rgh, CL + 1) = Range("G42").Value
CL = CL + 2
End If
End If
Next I
Workbooks(FlNewName).Close SaveChanges:=False
Rgh = Rgh + 1
Wend
'Elimina file senza valori e crea collegamenti ipertestuali
Rgh = 2
While Riep.Cells(Rgh, 1) <> ""
If Riep.Cells(Rgh, 2) = "" Then
Riep.Range(Cells(Rgh, 1), Cells(Rgh, 9)).Select
Selection.Delete Shift:=xlUp
Else
Cells(Rgh, 1).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Cells(Rgh, 1).Text _
, TextToDisplay:=Cells(Rgh, 1).Text
Rgh = Rgh + 1
End If
Wend
Cells(Rgh, 1).Select
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Questo è il codice con le ultime modifiche proposte da Anthony ed altre che ho appena effettuato.
Nell'ultima parte relativa alla creazione dei collegamenti ipertestuali ho aggiunto un controllo che mi elimina tutte i file in cui non sono evidenziati i mesi da gennaio ad aprile, in automatico, senza necessità di utilizzare il filtro automatico.
Ciao e buon lavoro
Tribuno
