VBA copy worksheet and delete columns based on value

Sparky1983

New Member
Joined
Feb 19, 2021
Messages
6
Office Version
  1. 365
Platform
  1. Windows
Hi

I have the following code working so that it copies the “Template” tab and renames it based on a table in the summary tab

Private Sub CommandButton1_Click()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range
Set sh1 = Sheets("Template")
Set sh2 = Sheets("Summary")
For Each c In sh2.Range("A3", sh2.Cells(Rows.Count, 1).End(xlUp))
sh1.Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = c.Value: ActiveSheet.Range("G5") = c.Value
Next
End Sub

The "Template" has pre-populated information up to column GE but a lot of this can be deleted each time (e.g. the first tab may need all the info in the first 40 columns but second tab may only need the first 24 columns)

I have therefore included in column B on “Summary” the number of columns required for each tab created but I am unsure on how to include this in the above so that it automatically deletes the excess columns not required and to then adjust the print range to show F2:Lastcolum133.

Any help would be much appreciated.

Thanks!
 

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
I cannot duplicate the error. However, I did notice that when the number in column B of Summary is less than 6 it produces an error on the PrintArea line, so I added an If...Then statement to fix that. I am wonering if there is something on worksheet Template that changes after column 15, although since you are deleting columns, it really should not matter.

VBA Code:
Private Sub CommandButton1_Click()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range, lc As Long
Set sh1 = Sheets("Template")
Set sh2 = Sheets("Summary")
For Each c In sh2.Range("A3", sh2.Cells(Rows.Count, 1).End(xlUp)) 'Gets company
sh1.Copy After:=Sheets(Sheets.Count) 'copies Template to last position in workbook
ActiveSheet.Name = c.Value: ActiveSheet.Range("G5") = c.Value 'Names new sheet
With ActiveSheet
    lc = .Cells.Find("*", , xlValues, xlPart, xlByColumns, xlPrevious).Column 'Gets last column as integer
    .Cells(1, c.Offset(, 1).Value + 1).Resize(, lc - c.Offset(, 1).Value).EntireColumn.Delete 'uses Summary!B value and lc value to calculate Column range to delete.
    lc = .Cells.Find("*", , xlValues, xlPart, xlByColumns, xlPrevious).Column 'Gets new last row
    If .Range("F2") <> "" Then 'Checks if Summary!B value >  5
        .PageSetup.PrintArea = .Range("F2", .Cells(Rows.Count, 6).End(xlUp)).Resize(, lc - 5).Address  'sets print area from cell F2 to right and down.
    End If 
End With
Next
End Sub

When testing, make sure your value in Summary!B is not greater than the last column (lc) in your Teplate sheet. That would produce an error.
 

Some videos you may like

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
This will check if column B value is greater than the last column integer, and if so, produce a message box alerting the user and then exit sub.

VBA Code:
Private Sub CommandButton1_Click()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range, lc As Long
Set sh1 = Sheets("Template")
Set sh2 = Sheets("Summary")
For Each c In sh2.Range("A3", sh2.Cells(Rows.Count, 1).End(xlUp))
sh1.Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = c.Value: ActiveSheet.Range("G5") = c.Value
With ActiveSheet
    lc = .Cells.Find("*", , xlValues, xlPart, xlByColumns, xlPrevious).Column
    If lc < c.Offset(, 1).Value Then
        MsgBox "There are not enough columns on the sheet to display " & c.Offset(, 1).Value & " Columns!", vbExclamaion, "COLUMN COUNT"
        Exit Sub
    End If
    .Cells(1, c.Offset(, 1).Value + 1).Resize(, lc - c.Offset(, 1).Value).EntireColumn.Delete
    lc = .Cells.Find("*", , xlValues, xlPart, xlByColumns, xlPrevious).Column
    If .Range("F2") <> "" Then
        .PageSetup.PrintArea = .Range("F2", .Cells(Rows.Count, 6).End(xlUp)).Resize(, lc - 5).Address
    End If
End With
Next
End Sub
 
Solution

Sparky1983

New Member
Joined
Feb 19, 2021
Messages
6
Office Version
  1. 365
Platform
  1. Windows
This will check if column B value is greater than the last column integer, and if so, produce a message box alerting the user and then exit sub.

VBA Code:
Private Sub CommandButton1_Click()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range, lc As Long
Set sh1 = Sheets("Template")
Set sh2 = Sheets("Summary")
For Each c In sh2.Range("A3", sh2.Cells(Rows.Count, 1).End(xlUp))
sh1.Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = c.Value: ActiveSheet.Range("G5") = c.Value
With ActiveSheet
    lc = .Cells.Find("*", , xlValues, xlPart, xlByColumns, xlPrevious).Column
    If lc < c.Offset(, 1).Value Then
        MsgBox "There are not enough columns on the sheet to display " & c.Offset(, 1).Value & " Columns!", vbExclamaion, "COLUMN COUNT"
        Exit Sub
    End If
    .Cells(1, c.Offset(, 1).Value + 1).Resize(, lc - c.Offset(, 1).Value).EntireColumn.Delete
    lc = .Cells.Find("*", , xlValues, xlPart, xlByColumns, xlPrevious).Column
    If .Range("F2") <> "" Then
        .PageSetup.PrintArea = .Range("F2", .Cells(Rows.Count, 6).End(xlUp)).Resize(, lc - 5).Address
    End If
End With
Next
End Sub

Thanks for this, this worked really well - it turns out there was a blank hidden column that I had not noticed which is what caused the error.
 

Watch MrExcel Video

Forum statistics

Threads
1,127,529
Messages
5,625,351
Members
416,096
Latest member
forevans

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