VBA resize table on a protected sheet

willow1985

Well-known Member
Joined
Jul 24, 2019
Messages
718
Office Version
  1. 365
Platform
  1. Windows
Hello,

I have been trying to solve a problem with a table that is on a protected sheet.

As I am sure many of you know Tables do not auto expand when the sheet is protected. I do however need the table to expand and have the sheet protected.

Any advise on a work around for this would be greatly appreciated.

Note: One of my ideas was to set off a macro when new data was entered in column C that would unlock the spreadsheet, expand the table and then re-lock the spreadsheet but I cannot seem to make this work/find the right code to expand the table without knowing the exact range.

The data starts at A3 and goes to the last row of data in column W, however there are some blanks periodically in various columns. The only column that does not have any blanks is column C.

The locked formulas are in columns L,M and N, there are other formulas that are not locked however in other columns.

There will also be situations when a macro will dump large blocks of data will be pasted in the last blank row in column A to column G so I don't know if using "new data in column C" as a trigger would work..

I hope someone can help as I feel stumped on this one.

My table name is "MF"

Thank you!

VBA Code:
If Target.CountLarge > 1 Then Exit Sub
If Not Intersect(Target, Range("C:C")) Is Nothing Then
    If Target.Value <> "" Then

  
        Worksheets("Master Forecast").Unprotect Password:="2150"

'Code to resize table or bring down data by 1 row??

Worksheets("Master Forecast").Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows _
        :=True, AllowInsertingHyperlinks:=True, AllowDeletingColumns:=True, _
        AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True, Password:="2150"

End If
End Sub
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,547
Office Version
  1. 365
Platform
  1. Windows
How about
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
   If Not Intersect(Target, Range("C:C")) Is Nothing Then
         Me.Unprotect Password:="2150"
         With Me.ListObjects("table1")
            .Resize .Range(1).CurrentRegion
         End With
         'Code to resize table or bring down data by 1 row??
         
         Me.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
            False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
            AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows _
            :=True, AllowInsertingHyperlinks:=True, AllowDeletingColumns:=True, _
            AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
            AllowUsingPivotTables:=True, Password:="2150"
   End If
End Sub
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"

jasonb75

Well-known Member
Joined
Dec 30, 2008
Messages
12,618
Office Version
  1. 365
Platform
  1. Windows
Looking at @Fluff's suggestion, I think I've been seriously trying to over-complicate things.

That looks like it should work so I'm going to wait for feedback before attempting anything else.
 

willow1985

Well-known Member
Joined
Jul 24, 2019
Messages
718
Office Version
  1. 365
Platform
  1. Windows
How about
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
   If Not Intersect(Target, Range("C:C")) Is Nothing Then
         Me.Unprotect Password:="2150"
         With Me.ListObjects("table1")
            .Resize .Range(1).CurrentRegion
         End With
         'Code to resize table or bring down data by 1 row??
       
         Me.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
            False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
            AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows _
            :=True, AllowInsertingHyperlinks:=True, AllowDeletingColumns:=True, _
            AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
            AllowUsingPivotTables:=True, Password:="2150"
   End If
End Sub

Got the following error:

1595441919493.png


For line: .Resize .Range(1).CurrentRegion

My Sheet looks like this (so not sure why getting this error?)

1595442178965.png
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,547
Office Version
  1. 365
Platform
  1. Windows
Do you have anything in row 1?
 

willow1985

Well-known Member
Joined
Jul 24, 2019
Messages
718
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

1 Formula in A1 to calculate today's date: =Today()

Sorry should have specified that. otherwise Row 1 is blank and is not part of the Table ("ML")
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,547
Office Version
  1. 365
Platform
  1. Windows
Ok, how about
VBA Code:
         With Me.ListObjects("table1")
            .Resize .Range(1).CurrentRegion.Offset(1).Resize(.Range(1).CurrentRegion.Rows.Count - 1)
         End With
 

willow1985

Well-known Member
Joined
Jul 24, 2019
Messages
718
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Works Perfect!

Thank you so much! This is exactly what I was looking for 😁😁
 

willow1985

Well-known Member
Joined
Jul 24, 2019
Messages
718
Office Version
  1. 365
Platform
  1. Windows
Ok, how about
VBA Code:
         With Me.ListObjects("table1")
            .Resize .Range(1).CurrentRegion.Offset(1).Resize(.Range(1).CurrentRegion.Rows.Count - 1)
         End With

I really owe you a coffee 😊

Thank you again
 

willow1985

Well-known Member
Joined
Jul 24, 2019
Messages
718
Office Version
  1. 365
Platform
  1. Windows
Looking at @Fluff's suggestion, I think I've been seriously trying to over-complicate things.

That looks like it should work so I'm going to wait for feedback before attempting anything else.

And thank you jasonb75 for not giving up on me 😉😊
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,547
Office Version
  1. 365
Platform
  1. Windows
Glad we could help & thanks for the feedback.
 

Watch MrExcel Video

Forum statistics

Threads
1,129,523
Messages
5,636,820
Members
416,943
Latest member
kitkat22

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