Moderatori: Anthony47, Flash30005
CD Directory principale
ATTRIB *.xls /s >C:\pippo123.txt
Shell ("c:\pippo.bat")
Workbooks.Open Filename:=NextName, UpdateLinks:=0
OWb = ActiveWorkbook.Name
For I= 1 to ActiveWorkbook.Worksheets.Count
ShN=Sheets(I).name
If ShN="Gennaio" or ShN="Febbraio" or ... Then
'istruzioni
End if
Workbooks(OWb).Close SaveChanges:=False
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
Shell ("C:\pippo.bat") 'Rileva file da controllare
Columns("A:E").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") = "Mese"
'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
If Range("J13") Or Range("J14") <> 0 Then
Riep.Cells(Rgh, CL) = Workbooks(FlNewName).Worksheets(I).Name
CL = CL + 1
End If
End If
Next I
Workbooks(FlNewName).Close SaveChanges:=False
Rgh = Rgh + 1
Wend
'Crea collegamenti ipertestuali
Rgh = 2
While Riep.Cells(Rgh, 1) <> ""
Cells(Rgh, 1).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Cells(Rgh, 1).Text _
, TextToDisplay:=Cells(Rgh, 1).Text
Rgh = Rgh + 1
Wend
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
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
Attenzione: nei miei file prova i fogli si chiamano Gennaio, Febbraio, Marzo, Aprile. Se nei tuoi il nome è diverso (es. gennaio oppure gen., ecc.), allora bisogna modificare questa parte del codice:
Codice: Seleziona tutto
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
Sub Controlla_redvin()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Shell ("C:\pippo.bat") 'Rileva file da controllare
OraVer = Now + TimeValue("00:00:03")
Do
Loop While Now < OraVer
Columns("A:E").Select
Selection.ClearContents 'Cancella dati in foglio riepilogo
'Selection.QueryTable.Delete
Range("A2").Select
'Importa dati da file pippo123.txt
Sheets(I).select '<<<<<<<<<<<<<<< AGGIUNGERE
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
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 '<<<< AGGIUNTA
CL = CL + 2 '<<<<<<<<<<<<< MODIFICATA
End If
Torna a Applicazioni Office Windows
Inserimento parziale valore cella in MessageBox Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 6 |
Inserire add.in nella barra di avvio veloce in excel 2003 Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 4 |
Excel: problema con date se devo unirle a testi Autore: valle1975 |
Forum: Applicazioni Office Windows Risposte: 5 |
Visitano il forum: Nessuno e 30 ospiti