COMPACT all from table

User avatar
sal21
PlatinumLounger
Posts: 3562
Joined: 26 Apr 2010, 17:36

COMPACT all from table

Post by 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
You do not have the required permissions to view the files attached to this post.

User avatar
HansV
Administrator
Posts: 71191
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: COMPACT all from table

Post by 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
Regards,
Hans

User avatar
sal21
PlatinumLounger
Posts: 3562
Joined: 26 Apr 2010, 17:36

Re: COMPACT all from table

Post by sal21 »

HansV wrote:
16 Apr 2021, 10:40
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
:clapping: