Ciao Massimo,
Ho questo problema. Ho un certo numero di file excel che hanno il foglio 1 con la stessa struttura a tabella. Dovrei fare un merge per avere un solo foglio riassuntivo. Potrei aprire ogni singolo foglio, selezionare l'area da copiare e incollare le singole
aree in un nuovo foglio. Per velocizzare volevo scrivere una routine che si posizionasse sulla cartella e per ogni file presente nella cartella effettuasse l'apertura, la copia e l'incolla nel nuovo file.
Sono un po' arrugginito con il vba (a memoria mi sembra che si può creare un ciclo for each ... next definendo come variabile il percorso della cartella) per cui se qualcuno ha un esempio a portata di mano sarei veramente grato.
Prova qualcosa del genere:
· Alt+F11 per aprire l'editor di VBA
· Alt+IMper inserire un nuovo modulo di codice
· Nel nuovo modulo vuoto, incolla il seguente codice:
'===========>>
Option Explicit
'----------->>
Public Sub Crea_Riepilogo_Di_Tutti_File_In_Cartella()
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, kCtr As Long
Dim i As Long, j As Long
Dim LRow As Long, iCol As Long
Dim sName As String
Dim sMsg As String, sTitle As String
Dim iButtons As Long
Dim CalcMode As Long
Const sSummary As String = "Riepilogo"
Const sPercorso As String = _
"**C:\Users\NDJ\Documents**" '<<=== Modifica
Const sFileType As String = "*.xlsx" '<<=== Modifica
Const sUltimaColonna As String = "G" '<<=== Modifica
On Error GoTo XIT
Set destWB = ThisWorkbook
With destWB
On Error Resume Next
With Application
.EnableEvents = False
.ScreenUpdating = False
CalcMode = .Calculation
.Calculation = xlCalculationManual
End With
If Not SheetExists(sSummary) Then
Set destSH = destWB.Sheets.Add( _
After:=.Sheets(.Sheets.Count))
destSH.Name = sSummary
Else
Set destSH = .Sheets(sSummary)
destSH.UsedRange.Offset(1).ClearContents
End If
End With
iCol = destSH.Columns(sUltimaColonna).Column
Set FSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(sPercorso)
If oFolder Is Nothing Then
Err.Raise 76
GoTo XIT
End If
Set oFiles = oFolder.Files
If oFiles Is Nothing Then
Err.Raise 100
GoTo XIT
End If
For Each oFile In oFiles
With oFile
If .Name Like sFileType Then
kCtr = kCtr + 1
Set srcWb = Workbooks.Open(oFile)
Set srcSH = srcWb.Sheets(1)
With srcSH
LRow = LastRow(srcSH, .Columns("A:A"))
Set srcRng = .Range("A2").Resize(LRow - 1, iCol)
jCtr = iCtr
iCtr = iCtr + LRow - 1
If Not IsArrayAllocated(arrHeaders) Then
arrHeaders = srcRng.Rows(0).Value
ReDim Preserve arrHeaders(1 To 1, 1 To iCol + 1)
arrHeaders(1, iCol + 1) = "File Originario"
End If
End With
ReDim Preserve arrIn(1 To iCol + 1, 1 To iCtr)
For i = 1 To LRow - 1
For j = 1 To iCol
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
If Not CBool(iCtr) Then
Call MsgBox( _
Prompt:="Nessun file del tipo designato " & sFileType _
& " è stato trovato ", _
Buttons:=vbInformation, _
Title:="REPORT")
Exit Sub
End If
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:
With Application
.ScreenUpdating = True
.Calculation = CalcMode
.EnableEvents = True
End With
Select Case Err.Number
Case Is = 0
sMsg = "Finito!" _
& vbNewLine & vbNewLine _
& kCtr & " file sono stati gestiti"
sTitle = "REPORT"
iButtons = vbInformation
Case Is = 76
sMsg = "Il percorso " & sPercorso & " non è valido!"
iButtons = vbCritical
sTitle = "CONTROLLA PERCORSO!"
Case 100
sMsg = "Nessun file del tipo " _
& sFileType _
& " è stato trovato!"
iButtons = vbCritical
sTitle = "CONTROLLA CARTELLA!"
Case Else
sMsg = "Errore " & Err.Number _
& vbNewLine & Err.Description
iButtons = vbCritical
sTitle = "ERRORE!"
End Select
Call MsgBox( _
Prompt:=sMsg, _
Buttons:=iButtons, _
Title:=sTitle)
End Sub
'--------->>
Public Function LastRow(SH As Worksheet, _
Optional rng As Range, _
Optional minRow As Long = 1, _
Optional sPassword As String)
Dim bProtected As Boolean
With SH
If rng Is Nothing Then
Set rng = .Cells
End If
bProtected = .ProtectContents = True
If bProtected Then
Application.ScreenUpdating = False
.Unprotect Password:=sPassword
End If
End With
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
If bProtected Then
SH.Protect Password:=sPassword, _
UserInterfaceOnly:=True
End If
Application.ScreenUpdating = True
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)
