COMPACT all from table

[sal21]

hummmm...
How to loop all sheet Tablex and copy all columns in TOTALE...
In effect i need t make a unique list in TOTALE from all row in tablex

[HansV]

Try this macro:

Code: Select all

Sub Combine()
    Dim wshS As Worksheet
    Dim wshT As Worksheet
    Dim s As Long
    Dim m As Long
    Dim c As Long
    Dim t As Long
    Application.ScreenUpdating = False
    Set wshT = Worksheets("TOTALE")
    t = 2
    For Each wshS In Worksheets
        s = wshS.Columns(1).Find(What:="COD.*COM.").Row
        If wshS.Name <> wshT.Name Then
            For c = 1 To 13 Step 3
                m = wshS.Cells(wshS.Rows.Count, c).End(xlUp).Row
                wshT.Cells(t, 1).Resize(m - s, 3).Value = wshS.Cells(s + 1, c).Resize(m - s, 3).Value
                t = t + m - s
            Next c
        End If
    Next wshS
    Application.ScreenUpdating = True
End Sub

[sal21]

Try this macro:

Code: Select all

Sub Combine()
    Dim wshS As Worksheet
    Dim wshT As Worksheet
    Dim s As Long
    Dim m As Long
    Dim c As Long
    Dim t As Long
    Application.ScreenUpdating = False
    Set wshT = Worksheets("TOTALE")
    t = 2
    For Each wshS In Worksheets
        s = wshS.Columns(1).Find(What:="COD.*COM.").Row
        If wshS.Name <> wshT.Name Then
            For c = 1 To 13 Step 3
                m = wshS.Cells(wshS.Rows.Count, c).End(xlUp).Row
                wshT.Cells(t, 1).Resize(m - s, 3).Value = wshS.Cells(s + 1, c).Resize(m - s, 3).Value
                t = t + m - s
            Next c
        End If
    Next wshS
    Application.ScreenUpdating = True
End Sub