Sub CreaFogli2()

 

    Dim wb As Workbook
    Dim shA As Worksheet
    Dim shB As Worksheet
    Dim shC As Worksheet
    Dim rng As Range
    Dim oRange As Range
    Dim vCol As Variant
    Dim colAccount As Collection
    
    Dim lRiga As Long
    Dim lRigaF As Long
    
    If ThisWorkbook.path = vbNullString Then
        MsgBox "Devi prima salvare la cartella corrente"
        Exit Sub
    End If
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    With ThisWorkbook
        Set shA = .Worksheets("Sap")
        Set shB = .Worksheets("Template")
    End With
    
    Set wb = Application.Workbooks.Add
    
    Set colAccount = New Collection
    
    With shA
        lRiga = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Range("A1:A" & lRiga).AdvancedFilter _
            Action:=xlFilterInPlace, Unique:=True
        Set rng = .Range("A2:A" & lRiga).SpecialCells(xlCellTypeVisible)
        On Error Resume Next
        For Each oRange In rng
            colAccount.Add Item:=oRange.Value, Key:=CStr(oRange.Value)
            DoEvents
        Next oRange
        On Error GoTo 0
        .ShowAllData
        For Each vCol In colAccount
            .Range("A1").AutoFilter Field:=1, Criteria1:=vCol
            lRigaF = .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
            shB.Copy Before:=wb.Worksheets("Sheet1")
            Set shC = wb.Worksheets("Template")
            With shC
                .Name = vCol
                .Range("C10").Value = vCol
                .Range("C11").Formula = "=VLOOKUP(C10,'[Lean.xlsm]Trial Balance'!$A$1:$E$284,2,0)"
                .Range("F15").Formula = "=VLOOKUP(C10,'[Lean.xlsm]Trial Balance'!$A$1:$E$284,3,0)"
                .Range("G15").Formula = "=VLOOKUP(C10,'[Lean.xlsm]Trial Balance'!$A$1:$E$284,4,0)"
                If lRigaF > 1 Then
                    .Range("B17:B" & (15 + lRigaF)).EntireRow.Insert
                End If
            End With
            .Range("B2:H" & lRiga).SpecialCells(xlCellTypeVisible).Copy
            shC.Range("B17").PasteSpecial Paste:=xlPasteValues
        Next vCol
        With wb
            .Worksheets(Array("Sheet1", "Sheet2", "Sheet3")).Delete
            
        End With
        .AutoFilterMode = False
    End With
    

    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

 

    Set rng = Nothing
    Set shA = Nothing
    Set shB = Nothing
    Set shC = Nothing
    Set wb = Nothing

 

End Sub