Copy data within a specific table

S

sofas

Well-known Member
Joined
Sep 11, 2022
Messages
504
Office Version
  1. 2019
Platform
  1. Windows
Hello, how can I copy the filtered data inside a specific table instead of copying it in a regular range, for example tableau11

VBA Code: 
Set SH1 = ThisWorkbook.Sheets("Recherche_ par date")
Set sh = ThisWorkbook.Sheets("Touts le valeurs ")
lastrow = sh.Cells(Rows.Count, "A").End(xlUp).Row
sh.Range("A8:ae" & lastrow).AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=SH1.Range("AG1:AH2"), _
CopyToRange:=SH1.Range("A9:ae9"), _
Unique:=True
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
VBA Code: 
    Sheets("Touts le valeurs ").Range("Names[#All]").AdvancedFilter Action:= _
        xlFilterCopy, CriteriaRange:=Range("'Recherche_ par date'!Criteria"), _
        CopyToRange:=Range("A9:AE9"), Unique:=False
 

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).
Sort by date Sort by votes
If the data is already filtered you can copy the data in this way and paste it, for example, in Sheet3
VBA Code: 
Sub CopyFilterTable()
  Dim sh As Worksheet
  Dim tbl As ListObject
 
  Set sh = Sheets("Touts le valeurs ")
  Set tbl = sh.ListObjects("tableau11")
  tbl.DataBodyRange.SpecialCells(xlCellTypeVisible).Copy Sheets("Sheet3").Range("B2")
End Sub

If you also want to copy the header use like this:
Rich (BB code): 
tbl.Range.SpecialCells(xlCellTypeVisible).Copy Sheets("Hoja3").Range("B2")

----- --
But I see that you ask "how can I copy the filtered data inside a specific table" but your code has an advanced filter, in that case:
The data in "Touts le valeurs " sheet
The criteria in "Recherche_ par date" sheet
And the results in "Sheet3" (for example)

VBA Code: 
Sub CopyFilterTable_()
  Dim sh As Worksheet
  Dim tbl As ListObject
 
  Set sh = Sheets("Touts le valeurs ")
  Set tbl = sh.ListObjects("tableau11")

  tbl.Range.AdvancedFilter Action:=xlFilterCopy, _
    CriteriaRange:=Range("'Recherche_ par date'!Criteria"), _
    CopyToRange:=Sheets("Sheet3").Range("A9"), Unique:=False
End Sub
 
Upvote 0
DanteAmor said:
If the data is already filtered you can copy the data in this way and paste it, for example, in Sheet3
VBA Code: 
Sub CopyFilterTable()
  Dim sh As Worksheet
  Dim tbl As ListObject
 
  Set sh = Sheets("Touts le valeurs ")
  Set tbl = sh.ListObjects("tableau11")
  tbl.DataBodyRange.SpecialCells(xlCellTypeVisible).Copy Sheets("Sheet3").Range("B2")
End Sub

If you also want to copy the header use like this:
Rich (BB code): 
tbl.Range.SpecialCells(xlCellTypeVisible).Copy Sheets("Hoja3").Range("B2")

----- --
But I see that you ask "how can I copy the filtered data inside a specific table" but your code has an advanced filter, in that case:
The data in "Touts le valeurs " sheet
The criteria in "Recherche_ par date" sheet
And the results in "Sheet3" (for example)

VBA Code: 
Sub CopyFilterTable_()
  Dim sh As Worksheet
  Dim tbl As ListObject
 
  Set sh = Sheets("Touts le valeurs ")
  Set tbl = sh.ListObjects("tableau11")

  tbl.Range.AdvancedFilter Action:=xlFilterCopy, _
    CriteriaRange:=Range("'Recherche_ par date'!Criteria"), _
    CopyToRange:=Sheets("Sheet3").Range("A9"), Unique:=False
End Sub
Click to expand...
I mean, I want to copy the data from table1 after filtering it to table11
 
Upvote 0
On a copy of your workbook see if this does what you want. It copies from the Table Names to the Table tableau11

VBA Code: 
Sub TestCopyTableToTable()

    Dim SH1 As Worksheet, sh As Worksheet
    Dim tblNames As ListObject, tbl11 As ListObject
    Dim tbl11NewRow As ListRow

    Set SH1 = ThisWorkbook.Sheets("Recherche_ par date")
    Set sh = ThisWorkbook.Sheets("Touts le valeurs")

    Set tblNames = Range("Names").ListObject
    Set tbl11 = Range("tableau11").ListObject
    
    Dim lastDataCell_11 As Range
    Dim lastCell_11 As Range
    Set lastDataCell_11 = tbl11.ListColumns(1).Range.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    Set lastCell_11 = tbl11.ListRows(tbl11.DataBodyRange.Rows.Count).Range(1)
    
    If tbl11.DataBodyRange Is Nothing Then
        Set tbl11NewRow = tbl11.ListRows.Add
    ElseIf lastDataCell_11.Row = lastCell_11.Row Then
        Set tbl11NewRow = tbl11.ListRows.Add
    Else
        Set tbl11NewRow = tbl11.ListRows(tbl11.DataBodyRange.Rows.Count)
    End If
     
    Range("Names[#All]").AdvancedFilter Action:= _
        xlFilterCopy, CriteriaRange:=Range("Criteria"), _
        CopyToRange:=tbl11NewRow.Range.Cells(1), Unique:=False
        
    Dim tbl11_NewLastRow As Range
    Dim tbl11_AddRows As Long
    Set tbl11_NewLastRow = SH1.Cells(Rows.Count, tbl11.Range.Column).End(xlUp)
    Set lastCell_11 = tbl11.ListRows(tbl11.DataBodyRange.Rows.Count).Range(1)
    tbl11_AddRows = tbl11_NewLastRow.Row - lastCell_11.Row
        
    Dim Rng As Range
    Set Rng = Range(tbl11.Name & "[#All]").Resize(tbl11.Range.Rows.Count + tbl11_AddRows, tbl11.Range.Columns.Count)
  
    tbl11.Resize Rng
        
    tbl11NewRow.Range.Delete
   
End Sub
 
Upvote 0
Hello. Thank you for your interest . For the first time, the code worked and copied all the data without filtering between the selected dates. When I try again, I get an error message. The purpose of this is to filter the data and copy it into a table with the size of the number of filtered rows. When trying again, the previous results are deleted and the new ones are copied in the same way. No blank rows in the table


easyupload.io

easyupload.io

easyupload.io
easyupload.io easyupload.io
 

Attachments

  • Screenshot 2023-02-12 140645.png
    Screenshot 2023-02-12 140645.png
    23.2 KB · Views: 6
Upvote 0
Had we had visibility of the your criteria range initially we probably would have suggested autofilter rather than advanced filter.

In your sample file, Names is just a range name and "not" a table name.
Also your Criteria Range is using Headings that don't appear in the Table and as such don't work in an Advanced filter.

I have the code I have below relies on the following changed.
1) Delete your "Names" Named range and change the Table into a real excel table and call it "Names"
(its possible this all happened when you created the sample file)
2) In the sheet "Recherche_ par date" add the rows I have added with formulas and call those additional 4 cells "Criteria" with scope of Sheet.
You can then hide the rows, they are only being used by the Advanced filter.

20230212 VBA Copy From Table to Table sofas v02.xlsm
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAE
1 star Date Fin Date
24/02/20235/02/2023
3
4Range Name > Criteria >DateDate
5>=44961<=44962
6
7
8
9DateSemaineTailleMachinePoidsApsorbtionRétentionPoids Rewet1Rewet2Rewet3Diffusion PoidsAQR1AQR2AQR3RUL1RUL2RUL3Diffusion Column1Column2Column3Column4Column5Column6Column7Column8Column9Column10Column11
10
Recherche_ par date
Cell Formulas
RangeFormula
F5F5=">=" &F2
G5G5="<=" &G2


Then try this code:

VBA Code: 
Sub TestCopyTableToTable_v02_ZeroTable()

    Dim SH1 As Worksheet, sh As Worksheet
    Dim tblNames As ListObject, tbl11 As ListObject
    Dim tbl11NewRow As ListRow

    Set SH1 = ThisWorkbook.Sheets("Recherche_ par date")
    Set sh = ThisWorkbook.Sheets("Touts le valeurs")

    Set tblNames = Range("Names").ListObject
    Set tbl11 = Range("tableau11").ListObject
  
    If Not tbl11.DataBodyRange Is Nothing Then
        tbl11.DataBodyRange.Delete
    End If
  
    Set tbl11NewRow = tbl11.ListRows.Add
   
    Range("Names[#All]").AdvancedFilter Action:= _
        xlFilterCopy, CriteriaRange:=SH1.Range("Criteria"), _
        CopyToRange:=tbl11NewRow.Range.Cells(1), Unique:=False
      
    Dim tbl11_NewLastRow As Range
    Dim tbl11_AddRows As Long
    Dim lastCell_11 As Range
    Set tbl11_NewLastRow = SH1.Cells(Rows.Count, tbl11.Range.Column).End(xlUp)
    Set lastCell_11 = tbl11.ListRows(tbl11.DataBodyRange.Rows.Count).Range(1)
    tbl11_AddRows = tbl11_NewLastRow.Row - lastCell_11.Row
      
    Dim Rng As Range
    Set Rng = Range(tbl11.Name & "[#All]").Resize(tbl11.Range.Rows.Count + tbl11_AddRows, tbl11.Range.Columns.Count)
    tbl11.Resize Rng
      
    tbl11NewRow.Range.Delete        ' Delete the heading row brought in by the Advanced Filter
 
End Sub
 
Upvote 0
Solution
Alex Blakenburg said:
Had we had visibility of the your criteria range initially we probably would have suggested autofilter rather than advanced filter.

In your sample file, Names is just a range name and "not" a table name.
Also your Criteria Range is using Headings that don't appear in the Table and as such don't work in an Advanced filter.

I have the code I have below relies on the following changed.
1) Delete your "Names" Named range and change the Table into a real excel table and call it "Names"
(its possible this all happened when you created the sample file)
2) In the sheet "Recherche_ par date" add the rows I have added with formulas and call those additional 4 cells "Criteria" with scope of Sheet.
You can then hide the rows, they are only being used by the Advanced filter.

20230212 VBA Copy From Table to Table sofas v02.xlsm
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAE
1 star Date Fin Date
24/02/20235/02/2023
3
4Range Name > Criteria >DateDate
5>=44961<=44962
6
7
8
9DateSemaineTailleMachinePoidsApsorbtionRétentionPoids Rewet1Rewet2Rewet3Diffusion PoidsAQR1AQR2AQR3RUL1RUL2RUL3Diffusion Column1Column2Column3Column4Column5Column6Column7Column8Column9Column10Column11
10
Recherche_ par date
Cell Formulas
RangeFormula
F5F5=">=" &F2
G5G5="<=" &G2


Then try this code:

VBA Code: 
Sub TestCopyTableToTable_v02_ZeroTable()

    Dim SH1 As Worksheet, sh As Worksheet
    Dim tblNames As ListObject, tbl11 As ListObject
    Dim tbl11NewRow As ListRow

    Set SH1 = ThisWorkbook.Sheets("Recherche_ par date")
    Set sh = ThisWorkbook.Sheets("Touts le valeurs")

    Set tblNames = Range("Names").ListObject
    Set tbl11 = Range("tableau11").ListObject
 
    If Not tbl11.DataBodyRange Is Nothing Then
        tbl11.DataBodyRange.Delete
    End If
 
    Set tbl11NewRow = tbl11.ListRows.Add
  
    Range("Names[#All]").AdvancedFilter Action:= _
        xlFilterCopy, CriteriaRange:=SH1.Range("Criteria"), _
        CopyToRange:=tbl11NewRow.Range.Cells(1), Unique:=False
     
    Dim tbl11_NewLastRow As Range
    Dim tbl11_AddRows As Long
    Dim lastCell_11 As Range
    Set tbl11_NewLastRow = SH1.Cells(Rows.Count, tbl11.Range.Column).End(xlUp)
    Set lastCell_11 = tbl11.ListRows(tbl11.DataBodyRange.Rows.Count).Range(1)
    tbl11_AddRows = tbl11_NewLastRow.Row - lastCell_11.Row
     
    Dim Rng As Range
    Set Rng = Range(tbl11.Name & "[#All]").Resize(tbl11.Range.Rows.Count + tbl11_AddRows, tbl11.Range.Columns.Count)
    tbl11.Resize Rng
     
    tbl11NewRow.Range.Delete        ' Delete the heading row brought in by the Advanced Filter
 
End Sub
Click to expand...
Thank you. This was done when copying and pasting to create the sample. Now everything works very well.
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question
copy, paste special, resize & offset
Replies
0
Views
229
jdcar
J
M
  • Question
VBA Help - Advanced Filtering
Replies
1
Views
610
DanteAmor
DanteAmor
B
  • Question
tables vs cells
Replies
4
Views
419
BobtBuilder
B
S
  • Question
Copy the data of several columns to another sheet without duplicating
Replies
2
Views
370
sofas
S
M
  • Solved
Data Advanced filter problem
Replies
2
Views
280
mikemcbain
M

Forum statistics

Threads
1,216,588
Messages
6,131,589
Members
449,657
Latest member
Timber5

Share this page

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
Back
Top