Ciao Vincenzo,
Ma ancora deve finire la partita? :-D
Dimentica la partita - si tratta della fine del mondo! ((;-
Tornando comunque alla tua domanda, il tuo problema era dovuto al fatto che i file csv utilizzano un punto e virgola come separatore anzichè la virgola.
Quindi, sostituisci il codice precedente con la seguente versione:
'===========>>
Option Explicit
'----------->>
Public Sub Tester()
Dim FSO As Object
Dim oFile As Object
Dim oFiles As Object
Dim oFolder As Object
Dim destWB As Workbook
Dim srcSH As Worksheet, destSH As Worksheet
Dim srcRng As Range, destRng As Range
Dim arrIn() As Variant, arrHeaders() As Variant
Dim iCtr As Long, jCtr As Long
Dim i As Long, j As Long, iFile As Long
Dim LRow As Long, LCol As Long
Dim sName As String, sPath As String
Const sPercorso As String = _
"**C:\Utente\Documents**"
'<<=== Modifica
Const sSummary As String = "Riepilogo"
Const sNameType As String = "*.csv"
Set destWB = ThisWorkbook
With destWB
On Error Resume Next
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.Sheets(sSummary).Delete
.DisplayAlerts = True
Err.Clear
End With
On Error GoTo XIT
Set srcSH = destWB.Sheets.Add(after:=.Sheets(.Sheets.Count))
Set destSH = destWB.Sheets.Add(after:=.Sheets(.Sheets.Count))
End With
destSH.Name = sSummary
Set FSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(sPercorso)
Set oFiles = oFolder.Files
For Each oFile In oFiles
With oFile
If .Name Like sNameType Then
iFile = iFile + 1
sPath = oFile.Path
Application.StatusBar = "Sviluppando il file # " & iFile & ": " & sPath
Call ImportTextFile(sPath, srcSH)
With srcSH
LRow = LastRow(srcSH, .Columns("A:A"))
LCol = LastCol(srcSH)
Set srcRng = .Range("A2").Resize(LRow - 1, LCol)
jCtr = iCtr
iCtr = iCtr + LRow - 1
If Not IsArrayAllocated(arrHeaders) Then
arrHeaders = srcRng.Rows(0).Value
ReDim Preserve arrHeaders(1 To 1, 1 To LCol + 1)
arrHeaders(1, LCol + 1) = "File Originale"
End If
End With
ReDim Preserve arrIn(1 To LCol + 1, 1 To iCtr)
For i = 1 To LRow - 1
For j = 1 To LCol
arrIn(j, jCtr + i) = srcRng.Cells(i, j).Value
Next j
arrIn(j, jCtr + i) = oFile.Name
Next i
End If
End With
With srcSH
.UsedRange.ClearContents
.QueryTables(1).Delete
End With
Next oFile
With destSH
Set destRng = destSH.Range("A2").Resize(iCtr, j)
destRng.Value = Application.Transpose(arrIn)
With destRng.Rows(0)
.Value = arrHeaders
.Font.Bold = True
End With
.UsedRange.EntireColumn.AutoFit
End With
With Application
.DisplayAlerts = False
srcSH.Delete
.DisplayAlerts = True
.StatusBar = False
End With
Call MsgBox( _
Prompt:="Finito!" _
& vbNewLine _
& iFile & " sono stati aggiunti al foglio " & sSummary, _
Buttons:=vbInformation, _
Title:="REPORT")
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
'--------->>
Public Function LastCol(SH As Worksheet, _
Optional Rng As Range)
If Rng Is Nothing Then
Set Rng = SH.Cells
End If
On Error Resume Next
LastCol = Rng.Find(What:="*", _
after:=Rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
'--------->>
Public Function IsArrayAllocated(Arr As Variant) As Boolean
On Error Resume Next
IsArrayAllocated = IsArray(Arr) And _
Not IsError(LBound(Arr, 1)) And _
LBound(Arr, 1) <= UBound(Arr, 1)
End Function
'--------->>
Public Sub ImportTextFile(sFilename As String, SH)
With SH.QueryTables.Add(Connection:= _
"TEXT;" & sFilename, Destination:=SH.Range("$A$1"))
.Name = "1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 1252
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub
'<<========
Dato il gran numero di file da importare, ho approfittato per aggiungere un messaggio dinamico nella barra di stato per consigliarti dei progressi del codice:
Potresti scaricare il mio file di prova Vincenzo20160628.xlsm a:
https://www.dropbox.com/s/msr8uvnhrv4y2ps/Vincenzo20160628.xlsm?dl=0
In questo file, sul foglio Riepilogo, potresti vedere i risultati ottenuto da me creando un riepilogo dei 124 File CSV (!!!) che hai caricato.
===
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)
