Ciao Vincenzo,
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 LRow As Long, LCol As Long
Dim sName As String
Const sPercorso As String = "**C:\Users\Utente\Documents**"
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 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
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
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
'<<=========
- 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
===
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)
