Macro to copy Table1 to the end of Table2...

[obiwilson]

I realize this question is similar to what is being asked here and here. However, when I tried to adapt them for my use I ran into several issues.

On worksheet "Free IDs" I have Table1 from A1:J21 with headers, data validation and formulas.
On worksheet "MASTER LIST" I have Table2 with the same headers and no data atm (I removed all the historical data as it was a mess)

There is a button on the bottom of worksheet "FREE IDs" which needs to perform the following:
- copy data from Table1 (minus the header) to the end of Table2.
- clear data from Table1 from B2:J21 but keep data validation, formulas and set background to no fill color.
or
- clear data from Table1 keeping data validation, formulas, set background to no fill and repopulate column A (A2:A21) with sequential numbers carrying on from what was cleared. So the previous A21+1 would be the new A2...

I have managed to do this, kind of, by recording a macro but it is a very ugly (Insert instead of xlup and loosing data validation...) way of doing it:

Sub CopyToMaster()
'
' CopyToMaster Macro
' copies the free ID table to the master table then resets the IDs.

    Range("A2:J21").Select
    Selection.Copy
    Sheets("MASTER LIST").Select
    Rows("2:2").Select
    Selection.Insert Shift:=xlDown
    Sheets("Free IDs").Select
    Range("A21").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.AutoFill Destination:=Range("A1:A21"), Type:=xlFillSeries
    Range("A1:A21").Select
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "ID"
    Range("A1").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight2
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With
    Range("B2:J21").Select
    Select

I know this can be done in an much more elegant way. Any help would be much appreciated.

 

[Alex Blakenburg]

1) Yes, I have just done this. Just confirming it was Text to Column?

Correct Text to Columns after changing the formating to be General.
Unfortunately the changing the format to General will not convert the data that has already is already there and you need the Text to Columns to convert it.
You may need to also format the 1st column of Master as General if it is currently also Text.

I have some commented out code that will take care of the above if it becomes an ongoing issue. It is tagged as OPTIONAL and you would need to uncomment it if you find you need it

Re: Item 4 - I changed the paste to values but decided to do a full paste for the email column afterwards. This assumes that the email column doesn't contain a formula.
I added it in because paste special loses the Hyperlink property.

Sub CopyToMaster_v03()

    Dim shtMstr As Worksheet, shtFree As Worksheet
    Dim tblMstr As ListObject, tblFree As ListObject
    Dim mstrNewRow As ListRow
    Dim freeItemNoMax As Long
    Dim freeRng As Range
    
    Set shtMstr = Worksheets("MASTER LIST")
    Set tblMstr = Range("Table2").ListObject
    
    Set shtFree = Worksheets("Free IDs")
    Set tblFree = Range("Table1").ListObject

    ' Cater for both empty 1st row and full databody range delete
    If tblMstr.DataBodyRange Is Nothing Then
        Set mstrNewRow = tblMstr.ListRows.Add
    ElseIf tblMstr.DataBodyRange.Rows.Count <> 1 Then
        Set mstrNewRow = tblMstr.ListRows.Add
    ElseIf tblMstr.ListRows(1).Range(1) <> "" Then
        Set mstrNewRow = tblMstr.ListRows.Add
    Else
        Set mstrNewRow = tblMstr.ListRows(1)
    End If
    
    ' Suppress table expansion dialogue box
    Application.DisplayAlerts = False
'        OPTIONAL - Convert Column 1 (column A) from Text to Number
'        tblFree.ListColumns(1).Range.NumberFormat = "General"
'        tblFree.ListColumns(1).Range.Value = tblFree.ListColumns(1).Range.Value
    
        tblFree.DataBodyRange.Copy
        mstrNewRow.Range.PasteSpecial Paste:=xlPasteValues
        ' Full Copy of email address column to retain Hyperlink property
        tblFree.ListColumns("Email address").DataBodyRange.Copy _
                Destination:=Intersect(mstrNewRow.Range, tblMstr.ListColumns("Email address").Range)
        
        freeItemNoMax = WorksheetFunction.Max(tblFree.ListColumns(1).Range)
        tblFree.DataBodyRange.Rows.Delete
    
        Set freeRng = tblFree.Range(1).Offset(1)
        freeRng = freeItemNoMax + 1
        freeRng.AutoFill Destination:=freeRng.Resize(20), Type:=xlFillSeries
    Application.DisplayAlerts = True
    
    With tblFree.DataBodyRange.Interior
          .Pattern = xlNone
          .TintAndShade = 0
          .PatternTintAndShade = 0
   
   '     .Pattern = xlSolid
   '     .PatternColorIndex = xlAutomatic
   '     .ThemeColor = xlThemeColorLight2
   '     .TintAndShade = 0.599993896298105
   '     .PatternTintAndShade = 0
    
    End With

End Sub

 

[obiwilson]

Correct Text to Columns after changing the formating to be General.
Unfortunately the changing the format to General will not convert the data that has already is already there and you need the Text to Columns to convert it.
You may need to also format the 1st column of Master as General if it is currently also Text.

I have some commented out code that will take care of the above if it becomes an ongoing issue. It is tagged as OPTIONAL and you would need to uncomment it if you find you need it

Re: Item 4 - I changed the paste to values but decided to do a full paste for the email column afterwards. This assumes that the email column doesn't contain a formula.
I added it in because paste special loses the Hyperlink property.

Sub CopyToMaster_v03()

    Dim shtMstr As Worksheet, shtFree As Worksheet
    Dim tblMstr As ListObject, tblFree As ListObject
    Dim mstrNewRow As ListRow
    Dim freeItemNoMax As Long
    Dim freeRng As Range
  
    Set shtMstr = Worksheets("MASTER LIST")
    Set tblMstr = Range("Table2").ListObject
  
    Set shtFree = Worksheets("Free IDs")
    Set tblFree = Range("Table1").ListObject

    ' Cater for both empty 1st row and full databody range delete
    If tblMstr.DataBodyRange Is Nothing Then
        Set mstrNewRow = tblMstr.ListRows.Add
    ElseIf tblMstr.DataBodyRange.Rows.Count <> 1 Then
        Set mstrNewRow = tblMstr.ListRows.Add
    ElseIf tblMstr.ListRows(1).Range(1) <> "" Then
        Set mstrNewRow = tblMstr.ListRows.Add
    Else
        Set mstrNewRow = tblMstr.ListRows(1)
    End If
  
    ' Suppress table expansion dialogue box
    Application.DisplayAlerts = False
'        OPTIONAL - Convert Column 1 (column A) from Text to Number
'        tblFree.ListColumns(1).Range.NumberFormat = "General"
'        tblFree.ListColumns(1).Range.Value = tblFree.ListColumns(1).Range.Value
  
        tblFree.DataBodyRange.Copy
        mstrNewRow.Range.PasteSpecial Paste:=xlPasteValues
        ' Full Copy of email address column to retain Hyperlink property
        tblFree.ListColumns("Email address").DataBodyRange.Copy _
                Destination:=Intersect(mstrNewRow.Range, tblMstr.ListColumns("Email address").Range)
      
        freeItemNoMax = WorksheetFunction.Max(tblFree.ListColumns(1).Range)
        tblFree.DataBodyRange.Rows.Delete
  
        Set freeRng = tblFree.Range(1).Offset(1)
        freeRng = freeItemNoMax + 1
        freeRng.AutoFill Destination:=freeRng.Resize(20), Type:=xlFillSeries
    Application.DisplayAlerts = True
  
    With tblFree.DataBodyRange.Interior
          .Pattern = xlNone
          .TintAndShade = 0
          .PatternTintAndShade = 0
 
   '     .Pattern = xlSolid
   '     .PatternColorIndex = xlAutomatic
   '     .ThemeColor = xlThemeColorLight2
   '     .TintAndShade = 0.599993896298105
   '     .PatternTintAndShade = 0
  
    End With

End Sub

Thanks a lot!

It worked but it moved the button and text below Table1 up into the table. Easy fix, I can just move it to the right side of the table.

I commented out the Email address column as I don't need the hyperlink and didn't want the background formatting carried over.
Is there a paste type that will keep the border formatting but nothing else? Values + border...

 

[obiwilson]

Thanks a lot!

It worked but it moved the button and text below Table1 up into the table. Easy fix, I can just move it to the right side of the table.
View attachment 83882
I commented out the Email address column as I don't need the hyperlink and didn't want the background formatting carried over.
Is there a paste type that will keep the border formatting but nothing else? Values + border...

Never mind, I just added border to the Master List and moved the button.
I have marked as SOLVED!

Thank you for your help.

 

[Alex Blakenburg]

Thanks for letting me know. Glad I could help.
If you apply the border in advance to the "whole" Table or whole column, it should become a border property and be applied to any new rows or columns.
Another option is to use a Table Style and if none suit create a Custom Style and apply that to the table.