Copy table headers from current sheet to newly created sheet in excel vba

[Vincent88]

I use below code to duplicate a worksheet with a dynamic table, then clear all contents, embedded items and pictures of whole sheet but I need to copy all headers' value of the table back to new sheet but failed. Need help !
CODE
Sub BlankSheet()
If ActiveWorkbook Is ThisWorkbook Then
Dim ws As Worksheet
Set ws = ActiveSheet
Dim LastColumn As Long

LastColumn = ws.Range("A1").CurrentRegion.Columns.Count

On Error Resume Next
Application.DisplayAlerts = False
ws.Range(Cells(1, 1), Cells(1, LastColumn)).Copy
ws.Copy before:=ActiveSheet
szToday = Format(Date, "d mmm yyyy")
ActiveSheet.name = szToday
Application.DisplayAlerts = True

'Clear All Contents
ActiveSheet.Cells.ClearContents
ActiveSheet.OLEObjects.Visible = True
ActiveSheet.OLEObjects.Delete
ActiveSheet.Pictures.Visible = True
ActiveSheet.Pictures.Delete
ActiveSheet.Range(Cells(1, 1)).Paste

End If
End Sub

 

[HaHoBe]

Hi Vincent88,

maybe try this code

Sub BlankSheet02()
'https://www.mrexcel.com/board/threads/copy-table-headers-from-current-sheet-to-newly-created-sheet-in-excel-vba.1169715/
  Dim ws As Worksheet
  Dim LastColumn As Long

  If ActiveWorkbook Is ThisWorkbook Then
    Set ws = ActiveSheet
    
    LastColumn = ws.Range("A1").CurrentRegion.Columns.Count
    
    On Error Resume Next
    Application.DisplayAlerts = False
  ''  ws.Range(Cells(1, 1), Cells(1, LastColumn)).Copy
    ws.Copy before:=ActiveSheet
  ''  szToday = Format(Date, "d mmm yyyy")
    ActiveSheet.Name = Format(Date, "d mmm yyyy")
    Application.DisplayAlerts = True
    
    'Clear All Contents
    With ActiveSheet
      .Cells.ClearContents
      With .OLEObjects
        .Visible = True
        .Delete
      End With
      With .Pictures
        .Visible = True
        .Delete
      End With
      .Range("A1").Resize(1, LastColumn).Value = ws.Range("A1").Resize(1, LastColumn).Value
    End With
    Set ws = Nothing
  End If

End Sub

Ciao,
Holger

 

[Vincent88]

Hi Vincent88,

maybe try this code

Sub BlankSheet02()
'https://www.mrexcel.com/board/threads/copy-table-headers-from-current-sheet-to-newly-created-sheet-in-excel-vba.1169715/
  Dim ws As Worksheet
  Dim LastColumn As Long

  If ActiveWorkbook Is ThisWorkbook Then
    Set ws = ActiveSheet
   
    LastColumn = ws.Range("A1").CurrentRegion.Columns.Count
   
    On Error Resume Next
    Application.DisplayAlerts = False
  ''  ws.Range(Cells(1, 1), Cells(1, LastColumn)).Copy
    ws.Copy before:=ActiveSheet
  ''  szToday = Format(Date, "d mmm yyyy")
    ActiveSheet.Name = Format(Date, "d mmm yyyy")
    Application.DisplayAlerts = True
   
    'Clear All Contents
    With ActiveSheet
      .Cells.ClearContents
      With .OLEObjects
        .Visible = True
        .Delete
      End With
      With .Pictures
        .Visible = True
        .Delete
      End With
      .Range("A1").Resize(1, LastColumn).Value = ws.Range("A1").Resize(1, LastColumn).Value
    End With
    Set ws = Nothing
  End If

End Sub

Ciao,
Holger

Hi HaHoBe,
it works. However it did not duplicate the dynamic table to the new workhsheet as I wish. Please help to modify it to copy the dynamic table (from A2 to last column of it) or add code to create a dynamic table in your script.

 

[Marc L]

Hi,​

​

what do you call a 'dynamic table' as within your code nothing seems to be a table ?!​

​

Another point : this kind of code does not need On Error codeline, without it's easier to debug yourself where your logic fails !​

​

As usual an accurate attachment helps to help …​

 

[HaHoBe]

Hi Vincent88,

just add two lines of code and adjust the name of the table as well as the look (here it´s the name of the sheet for the table as well and a light blue shading):

Sub BlankSheet03()
'https://www.mrexcel.com/board/threads/copy-table-headers-from-current-sheet-to-newly-created-sheet-in-excel-vba.1169715/
  Dim ws As Worksheet
  Dim LastColumn As Long
  Dim strSheetName As String

  If ActiveWorkbook Is ThisWorkbook Then
    Set ws = ActiveSheet
  
    LastColumn = ws.Range("A1").CurrentRegion.Columns.Count
  
    On Error Resume Next
    Application.DisplayAlerts = False
  ''  ws.Range(Cells(1, 1), Cells(1, LastColumn)).Copy
    ws.Copy before:=ActiveSheet
    strSheetName = Format(Date, "d mmm yyyy")
    ActiveSheet.Name = strSheetName
    Application.DisplayAlerts = True
  
    'Clear All Contents
    With ActiveSheet
      .Cells.ClearContents
      With .OLEObjects
        .Visible = True
        .Delete
      End With
      With .Pictures
        .Visible = True
        .Delete
      End With
      .Range("A1").Resize(1, LastColumn).Value = ws.Range("A1").Resize(1, LastColumn).Value
      .ListObjects.Add(xlSrcRange, .Range("A1").Resize(2, LastColumn), , xlYes).Name = strSheetName
      .ListObjects(strSheetName).TableStyle = "TableStyleLight2"
    End With
    Set ws = Nothing
  End If

End Sub

Ciao,
Holger

 

[Vincent88]

Hi Vincent88,

just add two lines of code and adjust the name of the table as well as the look (here it´s the name of the sheet for the table as well and a light blue shading):

Sub BlankSheet03()
'https://www.mrexcel.com/board/threads/copy-table-headers-from-current-sheet-to-newly-created-sheet-in-excel-vba.1169715/
  Dim ws As Worksheet
  Dim LastColumn As Long
  Dim strSheetName As String

  If ActiveWorkbook Is ThisWorkbook Then
    Set ws = ActiveSheet
 
    LastColumn = ws.Range("A1").CurrentRegion.Columns.Count
 
    On Error Resume Next
    Application.DisplayAlerts = False
  ''  ws.Range(Cells(1, 1), Cells(1, LastColumn)).Copy
    ws.Copy before:=ActiveSheet
    strSheetName = Format(Date, "d mmm yyyy")
    ActiveSheet.Name = strSheetName
    Application.DisplayAlerts = True
 
    'Clear All Contents
    With ActiveSheet
      .Cells.ClearContents
      With .OLEObjects
        .Visible = True
        .Delete
      End With
      With .Pictures
        .Visible = True
        .Delete
      End With
      .Range("A1").Resize(1, LastColumn).Value = ws.Range("A1").Resize(1, LastColumn).Value
      .ListObjects.Add(xlSrcRange, .Range("A1").Resize(2, LastColumn), , xlYes).Name = strSheetName
      .ListObjects(strSheetName).TableStyle = "TableStyleLight2"
    End With
    Set ws = Nothing
  End If

End Sub

Ciao,
Holger

Hi HaHoBe,
It does the job now. One last thing.
I use below code to call your marco but the msg box pop up when creating the new sheet and even after the sheet is created (pop up twice). Actually I only want the msgbox to pop up if today's sheet is already existed when I run the marco. Please help me to fix it.

Function DoesSheetExists(sh As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Sheets(sh)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExists = True
End Function


Sub Check()
strSheetName = Format(Date, "d mmm yyyy")
Dim s As String: s = (strSheetName)
Application.DisplayAlerts = False

If DoesSheetExists(s) Then
MsgBox "Sheet " & s & " already existed"
Else
Call Module18.BlankSheet03
End If

Application.DisplayAlerts = True

End Sub

 

[Vincent88]

Hi HaHoBe,
It does the job now. One last thing.
I use below code to call your marco but the msg box pop up when creating the new sheet and even after the sheet is created (pop up twice). Actually I only want the msgbox to pop up if today's sheet is already existed when I run the marco. Please help me to fix it.

Function DoesSheetExists(sh As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Sheets(sh)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExists = True
End Function


Sub Check()
strSheetName = Format(Date, "d mmm yyyy")
Dim s As String: s = (strSheetName)
Application.DisplayAlerts = False

If DoesSheetExists(s) Then
MsgBox "Sheet " & s & " already existed"
Else
Call Module18.BlankSheet03
End If

Application.DisplayAlerts = True

End Sub

 

[HaHoBe]

Hi Vincent,

code works well and as intended for me.

But I have some questions by now.

Why do you use Application.DisplayAlerts? You don´t delete any shets so that comand is of no use and I try to avoid turning off the system alerts unless necessary.

Why do you use two variables for one purpose (strSheetname and s)? Why do you put brackets around strSheetName? No need to do so from what I know, and one variable would serve the purpose well enough.

You copy the original sheet and then delete the contents. Is there a reason why not to insert a fresh worksheet, copy over the first two rows from the sheet you started from and depending on if there are any formulas cycle through the cells of the second row and delete the constants or simply delete the contents if only constants are used? Just my two cents on that.

And maybe use code-tags for displaying your code and make it easier to read and copy in the future - thanks for that in advance.

Ciao,
Holger

 

[HaHoBe]

Hi Vincent88,

it may have been to obvous for me but I´d like to ask if you considered using a template sheet set up as you would need it and use that for the copy and rename instead of copying an existing sheet, deleting items and rebuilding from scratch.

Ciao,
Holger

 

[Vincent88]

Hi Vincent,

code works well and as intended for me.

But I have some questions by now.

Why do you use Application.DisplayAlerts? You don´t delete any shets so that comand is of no use and I try to avoid turning off the system alerts unless necessary.

Why do you use two variables for one purpose (strSheetname and s)? Why do you put brackets around strSheetName? No need to do so from what I know, and one variable would serve the purpose well enough.

You copy the original sheet and then delete the contents. Is there a reason why not to insert a fresh worksheet, copy over the first two rows from the sheet you started from and depending on if there are any formulas cycle through the cells of the second row and delete the constants or simply delete the contents if only constants are used? Just my two cents on that.

And maybe use code-tags for displaying your code and make it easier to read and copy in the future - thanks for that in advance.

Ciao,
Holger

Hi HaHoBe,
I am a beginner to learn VBA so I extracted those scripts from web.
I do feel the strSheetname variables seems redunant but no time to correct.
Copying current sheet seems easier for me cos I do not have to reset formats and copying table seems better for me cos the file is shared and some user my increase columns when use.

Function DoesSheetExists(sh As String) As Boolean
    Dim ws As Worksheet

    On Error Resume Next
    Set ws = ThisWorkbook.Sheets(sh)
    'Set ws = ThisWorkbook.Worksheets
    'On Error GoTo 0

    If Not ws Is Nothing Then DoesSheetExists = True
End Function


Sub Check()
    szToday = Format(Date, "d mmm yyyy")
    'strSheetName = Format(Date, "d mmm yyyy")
    Dim s As String: s = (szToday)
    'Dim s As String: s = (strSheetName)
    

    If DoesSheetExists(s) Then
        MsgBox "Sheet " & s & " does exist"
    Else
        Call Module18.BlankSheet03
             
        
    End If
End Sub