VBA copy worksheet and delete columns based on value

[Sparky1983]

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]

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.

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.

 

[JLGWhiz]

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.

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

 

[Sparky1983]

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.

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.