![](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 Vincenzo,
partendo dal thread
chiedo l'evoluzione del codice :-)
[Cut]
ho scoperto che il tuo bellissimo codice vba funziona egregiamentw con i csv e che, se io volessi farlo fuinzionare con degli xslx non basta cambiare l'estensione del file come di seguito:
Const sNameType As String = "*.xlsx"
:-(
in allegato i file e il mio risultato e poi una foto del pessimo risultato a seguito della modifica da me descritta......
help me!!!!!!!!!!!!!!!!!!
Il motivo per cui ti ho chiesto di aprire un nuovo thread, e il motivo per cui hai ottenuto il pessimo risultato indicato è che non si deve importare i file del tipo xlsx nello stesso modo che abbiamo importato i file CSV - anche se, in realtà, questi erano dei file con i campi dati separati da punti e virgola anziché virgole. Nel caso dei file CSV abbiamo utilizzato una query per importare i dati ma, per i file XLSX, possiamo semplicemente aprire ogni file come una nuova cartella di lavoro e quindi estrarre i dati di interesse.
Pertanto, prova qualcosa del genere:
- Alt+F11 per aprire l'editor di VBA
- Menù | Inserisci | Modulo (oppure Alt+IM) per inserire un nuovo modulo di codice
- Nel nuovo modulo vuoto, incolla il seguente codice:
'===========>>
Option Explicit
'----------->>
Public Sub Tester()
Dim FSO As Object
Dim oFile As Object
Dim oFiles As Object
Dim oFolder As Object
Dim srcWb As Workbook, 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
Dim iFile As Long
Dim LRow As Long, LCol As Long
Dim sName As String, sPath As String
Const sPercorso As String = _
"**C:\Users\Utente\Documents**" '<<=== Modifica
Const sSummary As String = "Riepilogo"
Const sNameType As String = "*.xlsx"
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 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
Set srcWb = Workbooks.Open(oFile)
Set srcSH = srcWb.Sheets(1)
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
srcWb.Close savechanges:=False
End If
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
Call MsgBox( _
Prompt:="Finito!" _
& vbNewLine _
& "I dati da " & iFile & " file sono stati aggiunti al foglio " _
& sSummary, _
Buttons:=vbInformation, _
Title:="REPORT")
XIT:
With Application
.ScreenUpdating = True
.StatusBar = False
End With
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
'<<=========
- Alt+Q per chiudere l'editor di VBA e tornare a Excel
- Salva il file con l’estensione xlsm
- Alt+F8 per aprire la finestra di gestione delle macro
- Seleziona Tester | Esegui
In modo analogo al codice precedente per importare i file csv, con questo codice si può seguire lo stato del suo avanzamento sulla barra di stato nella parte inferiore della finestra di Excel.
===
Regards,
Norman