Sub ImportaDatiMeteo()
On Error GoTo RigaErrore
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim sPath As String
With Application
.ScreenUpdating = False
End With
sPath = ActiveWorkbook.Path & "\" 'oppure ho inserito il percorso esatto della cartella contenete i file
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(sPath)
For Each objFile In objFolder.Files
If Right(objFile.Name, 3) = "csv" Then
ThisWorkbook.Worksheets.Add
ActiveSheet.Name = objFile.Name
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & sPath & objFile.Name, _
Destination:=Range("B2"))
.Name = "Cartel2"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 1250
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(2, 4, 1, 1, 1, 9, 9, 9, 9, 9, 9, 9, 9, 9, 2)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Rows("1:40").Select
Selection.RowHeight = 20
Range("B2:G2").Select
Selection.Font.Bold = True
Rows("1:40").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End If
Next
RigaChiusura:
Set objFile = Nothing
Set objFolder = Nothing
Set objFSO = Nothing
With Application
.ScreenUpdating = True
End With
Exit Sub
RigaErrore:
MsgBox Err.Number & vbNewLine & Err.Description
Resume RigaChiusura
End Sub
