Transfer table filtered data to new worksheet in respective column, 2nd tab data transferred under last row in respective columns.

Dave01

Board Regular
Joined
Nov 30, 2018
Messages
96
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows

Hi

The link above is an extract of a larger macro which works really well, however I am stuck on preparing my final report.

there are a number of tabs which are filtered for change, each tab comparing to the last. In my extract I have two, 09.30 & 12.30, so 12.30 compares to 9.30 to get the change results, works well.

What I am stuck with is transferring these onto another sheet called changes table.

The first transfer works well, although somewhat long winded, I tried many types of VB code, and tried shorting the lines, nothing worked except, individual activate copy and paste.

the second 12.30 tab doesnt cause any errors but doesnt do anything either, it should transfer the visible filtered columns under the last row used of the Changes tables in their respective columns. Im not sure whats happening here, I would be greatful if somebody could take a look. (the tabs use tables)

I tried using this


Set TME = ThisWorkbook.Worksheets("08.30")
'' TME.Range("A:A").Copy Destination:=NDC.Range("A1")
'' TME.Range("E:E").Copy Destination:=NDC.Range("B1")
'' TME.Range("F:F").Copy Destination:=NDC.Range("D1")
'' TME.Range("G:G").Copy Destination:=NDC.Range("C1")
''
instead of all this, but I kept getting errors of paste isnt the same size. Its a bit annoying because there are 7 tabs in total, which will make the program very big.

Sheets("9.30").Activate
Range("A2").Activate
Range(Selection, Selection.End(xlDown)).Copy
Sheets("Changes Table").Activate
Range("A3").Activate
ActiveSheet.Paste

Sheets("9.30").Activate
Range("E2").Activate
Range(Selection, Selection.End(xlDown)).Copy
Sheets("Changes Table").Activate
Range("c3").Activate
ActiveSheet.Paste


Sheets("9.30").Activate
Range("Y2").Activate
Range(Selection, Selection.End(xlDown)).Copy
Sheets("Changes Table").Activate
Range("B3").Activate
ActiveSheet.Paste

Sheets("9.30").Activate
Range("G2").Activate
Range(Selection, Selection.End(xlDown)).Copy
Sheets("Changes Table").Activate
Range("D3").Activate
ActiveSheet.Paste

Sheets("9.30").Activate
Range("F2").Activate
Range(Selection, Selection.End(xlDown)).Copy
Sheets("Changes Table").Activate
Range("E3").Activate
ActiveSheet.Paste


Sheets("9.30").Activate
Range("z2").Activate
Range(Selection, Selection.End(xlDown)).Copy
Sheets("Changes Table").Activate
Range("F3").Activate
ActiveSheet.Paste




Many thanks

Dave.
 

Dave01

Board Regular
Joined
Nov 30, 2018
Messages
96
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
Hi fluff,

Im pretty ,much there, Im just getting an error , I changed the two lines.

Shts = Array("9.30", "Table3", "10.30", "Table4", "12.30", "Table5", "14.15", "Table6", "3.30", "Table7", "4.30", "Table8")


Ary = Application.Index(.DataBodyRange, Application.Transpose(Rws), Array(1, 25, 5, 7, 6, 26))


which seems to work on the first tab 9.30

it doent seem to be able to move onto the 2nd tab, but maybe its because there is no Change status in there, although it tries to filter for it I guess it cant pick up the columns if there is no data, so I get the error Mismatch.
 

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
62,544
Office Version
  1. 365
Platform
  1. Windows
Ok, how about
VBA Code:
Sub Dave()
   Dim Ary As Variant, Rws As Variant, Shts As Variant
   Dim i As Long
   
   Shts = Array("9.30", "Table1", "12.30", "Table2")
   For i = 0 To UBound(Shts) Step 2
      With Sheets(Shts(i)).ListObjects(Shts(i + 1))
         Rws = Filter(.Parent.Evaluate(Replace("transpose(if(@=""Change"",row(@)-min(row(@))+1,""^""))", "@", .ListColumns("Compare").DataBodyRange.Address)), "^", False)
         If UBound(Rws) >= 0 Then
            Ary = Application.Index(.DataBodyRange, Application.Transpose(Rws), Array(1, 6, 2, 4, 3, 7))
            Sheets("Changes Table").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(Rws) + 1, 6) = Ary
         End If
      End With
   Next i
End Sub
 
Solution

Marc L

Well-known Member
Joined
Apr 5, 2021
Messages
1,251
Office Version
  1. 2010
Platform
  1. Windows
Hi, according to the initial attachment for good enough readers only a VBA demonstration to paste to the Sheet3 (Changes Table) worksheet module :​
VBA Code:
Sub Demo1()
    Dim S%, R&
        UsedRange.Offset(2).Clear
        Application.ScreenUpdating = False
    For S = 1 To Index - 1
        With Worksheets(S).[A1].CurrentRegion
            If Application.Subtotal(103, .Columns(1)) > 1 Then
                      R = UsedRange.Rows.Count + 1
                With .Rows("2:" & .Rows.Count).SpecialCells(12).Columns
                     .Item(1).Copy Cells(R, 1)
                     .Item(6).Copy Cells(R, 2)
                     .Item(2).Copy Cells(R, 3)
                     .Item(4).Copy Cells(R, 4)
                     .Item(3).Copy Cells(R, 5)
                     .Item(7).Copy Cells(R, 6)
                End With
            End If
        End With
    Next
        Application.ScreenUpdating = True
End Sub
 

Dave01

Board Regular
Joined
Nov 30, 2018
Messages
96
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
Hi Fluff,

Im getting an error saying Application Defined or Object defined error on this line

Sheets("Change Table").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(Rws) + 1, 6) = Ary

I did get it to work before the changes with just adding this

'On Error Resume Next

thanks Marc L I havnt had a chance to try it out yet
 

Dave01

Board Regular
Joined
Nov 30, 2018
Messages
96
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows

ADVERTISEMENT

Hi Mark,

I get an object error here


UsedRange.Offset(2).Clear
 

Dave01

Board Regular
Joined
Nov 30, 2018
Messages
96
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
if i add this On Error Resume Next

it fullly generates the report
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
62,544
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Im getting an error saying Application Defined or Object defined error on this line
Was that with my code, or did you retype it?
 

Dave01

Board Regular
Joined
Nov 30, 2018
Messages
96
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
Hi Fluff

That was with yours,

I copied and pasted

the only major changes were from the original was

If UBound(Rws) >= 0 Then



Seets("Changes Table").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(Rws) + 1, 6) = Ary
End If

this was changed from
Ary = Application.Index(.DataBodyRange, Application.Transpose(Rws), Array(1, 6, 2, 4, 3, 7))


to (column ref only)

Ary = Application.Index(.DataBodyRange, Application.Transpose(Rws), Array(1, 25, 5, 7, 6, 26))


the Xx s I put in because it c ontained actual data (it is correct otherwise)
thats with the on error resume next
 

Attachments

  • 1.JPG
    1.JPG
    62.3 KB · Views: 2

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
62,544
Office Version
  1. 365
Platform
  1. Windows
The only way I can get the error your reporting is if the +1 is missing from this line
VBA Code:
Seets("Changes Table").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(Rws) + 1, 6) = Ary
so not quite sure what's happening.
 

Dave01

Board Regular
Joined
Nov 30, 2018
Messages
96
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
Not sure it looks the same as yours.
 

Attachments

  • 1.JPG
    1.JPG
    111.1 KB · Views: 3
  • 2.JPG
    2.JPG
    77.9 KB · Views: 3

Forum statistics

Threads
1,141,614
Messages
5,707,410
Members
421,508
Latest member
Jalayne

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top