![](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)
Microsoft 365 e Office | Excel | Per la casa | Windows
Una famiglia di software per fogli di calcolo Microsoft con strumenti per l'analisi, la creazione di grafici e la comunicazione dei dati.
Ciao Giuseppe,
in effetti nella cartella condivisa esistevano dei file excel che non erano CSV originali.
A me va benissimo il codice come creato.
Ti condivido la cartella originale ove faccio i test ed il frimo foglio me lo crea bianco pur essendo un file CSV.
Per il resto è tutto più che perfetto.
Se hai tempo, dai un occhio a questa cartella che sicuramente saprai dirmi perchè il primo file lo crea vuoto.
Se uno dei 356 file csv originariamente viene aperto in Excel utilizzando VBA, i dati vengono automaticamente suddivisi in colonne separate. Al contrario, se i 3 file csv appena caricati vengono aperti da VBA, i dati non vengono suddivisi ma, invece, visualizzati in un'unica colonna. Si deve concludere che i 3 file appena caricati sono stati creati in modo diverso dai precedenti 356 file.
Poiché il mio codice utilizza i dati nelle colonne B:E e i dati del file SA00000_01_03_2021.csv sono tutti visualizzati nella colonna A, nessun dato separato da virgole viene passato alla procedura ConvertireSeparatorePerCSV e, di conseguenza, viene salvato un file csv vuoto nella
directory Monte.
Tuttavia, ho rivisto il codice per gestire la possibilità che i file csv originali possano aprirsi in modalità divisa o non divisa. Eseguendo il codice rivisto, tutti i 359 file csv originali vengono gestiti correttamente e tutti i file csv archiviati nella directory Monte contengono i dati previsti.
Nel seguente codice aggiornato, le modifiche sono evidenziate in rosso:
'========>>
Option Explicit
'-------->>
Public Sub Tester()
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim WB As Workbook
Dim SH As Worksheet
Dim Rng As Range, Rng2 As Range
Dim arrIn As Variant
Dim sFolder\_Sorgente As String, sFolder\_Valle As String, sFolder\_Monte As String
Dim sPercorso\_Monte As String, sPercorso\_Valle As String
Dim sFileName As String
Dim vOld As Long, vNew As Long
Dim i As Long, iVal As Long
Dim iCtr As Long
Dim LRow As Long
Dim bFlag As Boolean
Const sPrefisso\_Monte As String = "Monte"
Const sPrefisso\_Valle As String = "Valle"
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "SELEZIONA LA DIRECTORY SORGENTE"
If .Show = -1 Then
sFolder\_Sorgente = .SelectedItems(1)
Else
Call MsgBox(Prompt:="Non hai selezionato una Directory SORGENTE!", \_
Buttons:=vbCritical, \_
Title:="ERRORE!")
Exit Sub
End If
End With
sPercorso\_Monte = sFolder\_Sorgente & "\" & sPrefisso\_Monte
sPercorso\_Valle = sFolder\_Sorgente & "\" & sPrefisso\_Valle
Set oFSO = CreateObject("Scripting.FileSystemObject")
If Not oFSO.FolderExists(sPercorso\_Monte) Then
oFSO.CreateFolder sPercorso\_Monte
End If
If Not oFSO.FolderExists(sPercorso\_Valle) Then
oFSO.CreateFolder sFolder\_Sorgente & "\" & sPrefisso\_Valle
End If
Set oFolder = oFSO.GetFolder(sFolder\_Sorgente)
On Error GoTo XIT
Application.ScreenUpdating = False
For Each oFile In oFolder.Files
If Right(oFile.Name, 3) = "csv" Then
FileCopy oFile.path, sPercorso\_Valle & "\" & sPrefisso\_Valle & oFile.Name
Set WB = Workbooks.Open(oFile)
ThisWorkbook.Sheets(1).Cells(iCtr + 1, 1).Value = oFile.Name
Set SH = WB.Sheets(1)
With SH
**If .UsedRange.Columns.Count = 1 Then**
**Call TextToCol(.UsedRange)**
**End If**
LRow = LastRow(SH)
Set Rng = .Range("B2:E" & LRow)
.Range("A1").Value = "xxx"
Set Rng2 = .UsedRange
.Range("A1").ClearContents
End With
arrIn = Rng.Value
For i = 1 To UBound(arrIn)
If TypeName(arrIn(i, 1)) = "String" Then
'\\Tutto bene, Excel non ha convertito questo dato in una data
ElseIf TypeName(arrIn(i, 1)) = "Date" Then
'\\ Excel avrebbe potuto erroneomente interpretato questo dato come una data in formato americano mm/gg/aaaa
'\\Quindi:
If Month(arrIn(i, 1)) <= 12 Then
arrIn(i, 1) = Format(arrIn(i, 1), "mm/dd/yyyy")
End If
End If
arrIn(i, 2) = CStr(Format(arrIn(i, 2), "hh:mm:ss"))
If arrIn(i, 3) <> 0 Then
vOld = arrIn(i, 3)
arrIn(i, 3) = arrIn(i, 3) + Int((20 - 5 + 1) \* Rnd + 5)
vNew = arrIn(i, 3)
arrIn(i, 4) = CLng(arrIn(i, 4) \* vNew / vOld)
End If
Next i
Rng.NumberFormat = "@"
Rng.Value = arrIn
sFileName = sPercorso\_Monte & "\" & sPrefisso\_Monte & oFile.Name
Call ConvertireSeparatorePerCSV(Rng2, sFileName)
WB.Close SaveChanges:=False
iCtr = iCtr + 1
End If
Next oFile
Call MsgBox(Prompt:="Finito!" & vbNewLine & iCtr & " File sono stati aggiornati", Buttons:=vbInformation, Title:="REPORT!")
XIT:
Application.ScreenUpdating = True
Set oFile = Nothing
Set oFolder = Nothing
Set oFSO = Nothing
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 Sub ConvertireSeparatorePerCSV(Rng As Range, sFullFileName As String)
Dim srcRng As Range
Dim rRow As Range
Dim rCell As Range
Dim sStr As String
Dim FName As Variant
Dim i As Long, j As Long
Const sSeparatoreVoluto As String = ","
Application.DisplayAlerts = False
Open sFullFileName For Output As #1
For Each rRow In Rng.Rows
sStr = ""
For Each rCell In rRow.Cells
If rCell.Column() = 1 Then
sStr = sStr & " " & sSeparatoreVoluto
Else
sStr = sStr & """" & rCell.Value & """" & sSeparatoreVoluto
End If
Next rCell
While Right(sStr, 1) = sSeparatoreVoluto
sStr = Left(sStr, Len(sStr) - 1)
Wend
Print #1, sStr
Next
Close #1
Application.DisplayAlerts = True
End Sub
'--------->>
Public Sub TextToCol(rCol As Range)
**rCol.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, \_**
**TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, \_**
**Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo \_**
**:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1)), \_**
**TrailingMinusNumbers:=True**
End Sub
'<<=========
Potresti scaricare il mio file aggiornato Giuseppe20220227.xlsm
===
Regards,
Norman