VBA Help - Split Data Worksheet with helper sheet into separate workbooks, preserve all formatting and structure and PW protect sheet

R

R19F84R

New Member
Joined
Mar 25, 2024
Messages
4
Office Version
  1. 365
Platform
  1. Windows
Hi All,

I have a spreadsheet that I need to split out a each unit and then password protect it. my spreadsheet will contain formatting and protected areas. I need to Retain all functionality in the split out files as well as update a master cell with the budget for that unit. I have some experience with VBA and can read and understand what it is doing, but not write it. I have found many posts online but nothing that does everything I need it to do. I suspect I will need the code to copy the whole workbook and then delete out anything not required in order to keep all the functionality. I also need each new file to be PW protected. I have created a helper sheet for this. Can anyone assist?

Mini sheet below.

Data Sample.xlsx
ABCDEFG
1Ref NoPreferred NameReckonable Join DatePlatformTypeUnitLocation
20001Person 101/01/1900Platform 1PermanentRU1Location1
30046Person 4601/01/1900Platform 2PermanentRU2Location1
40073Person 7301/01/1900Platform 3PermanentRU3Location1
50115Person 11501/01/1900Platform 2PermanentRU4Location9
60166Person 16601/01/1900Platform 1PermanentRU5Location1
70170Person 17001/01/1900Platform 2PermanentRU6Location1
80199Person 19901/01/1900Platform 5PermanentRU7Location2
90203Person 20301/01/1900Platform 5PermanentRU8Location9
100255Person 25501/01/1900Platform 3PermanentRU9Location1
110346Person 34601/01/1900Platform 3PermanentRU10Location1
120360Person 36001/01/1900Platform 5PermanentRU11Location2
130362Person 36201/01/1900Platform 4PermanentRU12Location1
140392Person 39201/01/1900Platform 1PermanentRU13Location1
150409Person 40901/01/1900Platform 1PermanentRU14Location1
160427Person 42701/01/1900Platform 5PermanentRU15Location9
170441Person 44101/01/1900Platform 3PermanentRU16Location9
180451Person 45101/01/1900Platform 5PermanentRU17Location1
190510Person 51001/01/1900Platform 6PermanentRU18Location9
200527Person 52701/01/1900Platform 5PermanentRU19Location5
210532Person 53201/01/1900Platform 5PermanentRU20Location1
220577Person 57701/01/1900Platform 1PermanentRU21Location10
230580Person 58001/01/1900Platform 6PermanentRU22Location2
240584Person 58401/01/1900Platform 5PermanentRU23Location14
250757Person 75701/01/1900Platform 1PermanentRU37Location1
260790Person 79001/01/1900Platform 5PermanentRU38Location1
270799Person 79901/01/1900Platform 4PermanentRU39Location21
280811Person 81101/01/1900Platform 2PermanentRU40Location1
290821Person 82101/01/1900Platform 1PermanentRU41Location1
300878Person 87801/01/1900Platform 4PermanentRU42Location11
310892Person 89201/01/1900Platform 5PermanentRU43Location1
320971Person 97101/01/1900Platform 1PermanentRU44Location1
330978Person 97801/01/1900Platform 1PermanentRU45Location1
341021Person 102101/01/1900Platform 1PermanentRU46Location1
351031Person 103101/01/1900Platform 5PermanentRU47Location1
361046Person 104601/01/1900Platform 4PermanentRU48Location1
371062Person 106201/01/1900Platform 5PermanentRU49Location1
381080Person 108001/01/1900Platform 5PermanentRU50Location1
391166Person 116601/01/1900Platform 4PermanentRU51Location1
401185Person 118501/01/1900Platform 1PermanentRU52Location1
411204Person 120401/01/1900Platform 6PermanentRU53Location1
421210Person 121001/01/1900Platform 5PermanentRU54Location9
431237Person 123701/01/1900Platform 5PermanentRU55Location1
441297Person 129701/01/1900Platform 2PermanentRU56Location1
451306Person 130601/01/1900Platform 3PermanentRU57Location1
461333Person 133301/01/1900Platform 5PermanentRU58Location1
471357Person 135701/01/1900Platform 2PermanentRU59Location19
481366Person 136601/01/1900Platform 3PermanentRU60Location1
491378Person 137801/01/1900Platform 6PermanentRU61Location9
501428Person 142801/01/1900Platform 4PermanentRU62Location11
Data



Helpsheet

Data Sample.xlsx
ABC
1UnitBudgetPassword
2RU110000Password1
3RU215000Password2
4RU320000Password3
5RU425000Password4
6RU530000Password5
7RU635000Password6
8RU740000Password7
9RU845000Password8
10RU950000Password9
11RU1055000Password10
12RU1160000Password11
13RU1265000Password12
14RU1370000Password13
15RU1475000Password14
16RU1580000Password15
17RU1685000Password16
18RU1790000Password17
19RU1895000Password18
20RU19100000Password19
21RU20105000Password20
22RU21110000Password21
23RU22115000Password22
24RU23120000Password23
25RU37125000Password24
26RU38130000Password25
27RU39135000Password26
28RU40140000Password27
29RU41145000Password28
30RU42150000Password29
31RU43155000Password30
32RU44160000Password31
33RU45165000Password32
34RU46170000Password33
35RU47175000Password34
36RU48180000Password35
37RU49185000Password36
38RU50190000Password37
39RU51195000Password38
40RU52200000Password39
41RU53205000Password40
42RU54210000Password41
43RU55215000Password42
44RU56220000Password43
45RU57225000Password44
46RU58230000Password45
47RU59235000Password46
48RU60240000Password47
49RU61245000Password48
50RU62250000Password49
Helper
 

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
Sort by date Sort by votes
This macro uses your suggested method: it loops through the Helper sheet rows and saves a copy of the Data sheet (not the whole workbook) as <Unit>.xlsx in the same folder as the macro workbook with the password, deletes all rows where column F doesn't equal <Unit> and resaves.

R19F84R said:
update a master cell with the budget for that unit
Click to expand...

I haven't done this bit because you haven't said which cell in which workbook should be updated.

As posted, the code processes only the first 4 data rows in the Helper sheet, so that you can test the macro and check that it creates the new workbooks correctly. Change For i = 2 To 5 'UBound(helperData) to For i = 2 To UBound(helperData) to process all the rows.

VBA Code: 
Public Sub Split_Data_Worksheet()

    Dim dataWs As Worksheet
    Dim helperData As Variant
    Dim i As Long, r As Long
    Dim saveInFolder As String
    Dim deleteRows As Range
    
    saveInFolder = ThisWorkbook.Path & "\"
    
    If Right(saveInFolder, 1) <> "\" Then saveInFolder = saveInFolder & "\"
    
    With ThisWorkbook
        Set dataWs = .Worksheets("Data")
        helperData = .Worksheets("Helper").Range("A1").CurrentRegion.Value
    End With
    
    Application.ScreenUpdating = False
    
    For i = 2 To 5 'UBound(helperData)
        Application.StatusBar = "Creating " & saveInFolder & helperData(i, 1) & ".xlsx"
        dataWs.Copy
        Application.DisplayAlerts = False 'suppress warning if file exists
        ActiveWorkbook.SaveAs saveInFolder & helperData(i, 1) & ".xlsx", FileFormat:=xlOpenXMLWorkbook, Password:=helperData(i, 3)
        Application.DisplayAlerts = True
        With ActiveWorkbook.Worksheets(1)
            Set deleteRows = Nothing
            For r = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
                If .Cells(r, "F").Value <> helperData(i, 1) Then
                    If deleteRows Is Nothing Then
                        Set deleteRows = .Rows(r)
                    Else
                        Set deleteRows = Union(deleteRows, .Rows(r))
                    End If
                End If
            Next
            deleteRows.Delete
        End With
        ActiveWorkbook.Close SaveChanges:=True
    Next
    
    Application.StatusBar = ""
    
    Application.ScreenUpdating = True
    
    MsgBox "Done"
    
End Sub
 
Upvote 1
John_w said:
This macro uses your suggested method: it loops through the Helper sheet rows and saves a copy of the Data sheet (not the whole workbook) as <Unit>.xlsx in the same folder as the macro workbook with the password, deletes all rows where column F doesn't equal <Unit> and resaves.



I haven't done this bit because you haven't said which cell in which workbook should be updated.

As posted, the code processes only the first 4 data rows in the Helper sheet, so that you can test the macro and check that it creates the new workbooks correctly. Change For i = 2 To 5 'UBound(helperData) to For i = 2 To UBound(helperData) to process all the rows.

VBA Code: 
Public Sub Split_Data_Worksheet()

    Dim dataWs As Worksheet
    Dim helperData As Variant
    Dim i As Long, r As Long
    Dim saveInFolder As String
    Dim deleteRows As Range
   
    saveInFolder = ThisWorkbook.Path & "\"
   
    If Right(saveInFolder, 1) <> "\" Then saveInFolder = saveInFolder & "\"
   
    With ThisWorkbook
        Set dataWs = .Worksheets("Data")
        helperData = .Worksheets("Helper").Range("A1").CurrentRegion.Value
    End With
   
    Application.ScreenUpdating = False
   
    For i = 2 To 5 'UBound(helperData)
        Application.StatusBar = "Creating " & saveInFolder & helperData(i, 1) & ".xlsx"
        dataWs.Copy
        Application.DisplayAlerts = False 'suppress warning if file exists
        ActiveWorkbook.SaveAs saveInFolder & helperData(i, 1) & ".xlsx", FileFormat:=xlOpenXMLWorkbook, Password:=helperData(i, 3)
        Application.DisplayAlerts = True
        With ActiveWorkbook.Worksheets(1)
            Set deleteRows = Nothing
            For r = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
                If .Cells(r, "F").Value <> helperData(i, 1) Then
                    If deleteRows Is Nothing Then
                        Set deleteRows = .Rows(r)
                    Else
                        Set deleteRows = Union(deleteRows, .Rows(r))
                    End If
                End If
            Next
            deleteRows.Delete
        End With
        ActiveWorkbook.Close SaveChanges:=True
    Next
   
    Application.StatusBar = ""
   
    Application.ScreenUpdating = True
   
    MsgBox "Done"
   
End Sub
Click to expand...
Amazing, thank you John. I will test it at work tomorrow.

The idea is in next available column (H in my example) the user will update a figure and there is a small table either above or to the right which gives the department its budget and then a cell that adds up their adjust column.

Let's say the cell the budget needs to update is k3.

Really appreciate your support on this.
 
Upvote 0
John_w said:
This macro uses your suggested method: it loops through the Helper sheet rows and saves a copy of the Data sheet (not the whole workbook) as <Unit>.xlsx in the same folder as the macro workbook with the password, deletes all rows where column F doesn't equal <Unit> and resaves.



I haven't done this bit because you haven't said which cell in which workbook should be updated.

As posted, the code processes only the first 4 data rows in the Helper sheet, so that you can test the macro and check that it creates the new workbooks correctly. Change For i = 2 To 5 'UBound(helperData) to For i = 2 To UBound(helperData) to process all the rows.

VBA Code: 
Public Sub Split_Data_Worksheet()

    Dim dataWs As Worksheet
    Dim helperData As Variant
    Dim i As Long, r As Long
    Dim saveInFolder As String
    Dim deleteRows As Range
   
    saveInFolder = ThisWorkbook.Path & "\"
   
    If Right(saveInFolder, 1) <> "\" Then saveInFolder = saveInFolder & "\"
   
    With ThisWorkbook
        Set dataWs = .Worksheets("Data")
        helperData = .Worksheets("Helper").Range("A1").CurrentRegion.Value
    End With
   
    Application.ScreenUpdating = False
   
    For i = 2 To 5 'UBound(helperData)
        Application.StatusBar = "Creating " & saveInFolder & helperData(i, 1) & ".xlsx"
        dataWs.Copy
        Application.DisplayAlerts = False 'suppress warning if file exists
        ActiveWorkbook.SaveAs saveInFolder & helperData(i, 1) & ".xlsx", FileFormat:=xlOpenXMLWorkbook, Password:=helperData(i, 3)
        Application.DisplayAlerts = True
        With ActiveWorkbook.Worksheets(1)
            Set deleteRows = Nothing
            For r = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
                If .Cells(r, "F").Value <> helperData(i, 1) Then
                    If deleteRows Is Nothing Then
                        Set deleteRows = .Rows(r)
                    Else
                        Set deleteRows = Union(deleteRows, .Rows(r))
                    End If
                End If
            Next
            deleteRows.Delete
        End With
        ActiveWorkbook.Close SaveChanges:=True
    Next
   
    Application.StatusBar = ""
   
    Application.ScreenUpdating = True
   
    MsgBox "Done"
   
End Sub
Click to expand...
Hi John,

Thank you - this worked brilliantly. IF you can offer any guidance on adapting the above to also populate cell k3 with the budget number - this will tick all the boxes. Thank you
 
Upvote 0
For the budget add this line after deleteRows.Delete

VBA Code: 
            .Range("K3").Value = helperData(i, 2)
 
Upvote 0
Hi John_w

Thank you so much for your help on the above it all works fantastically well. I want to protect the workbook and allow users to only edit column P. However when I try protecting the sheet it errors out on the deleterows.delete. Is this something you can assist me with?

Many Thanks
 
Upvote 0
With the sheet protected the code has to temporarily unprotect it and reprotect it.

Replace:

VBA Code: 
            deleteRows.Delete
            .Range("K3").Value = helperData(i, 2)

with:
VBA Code: 
            .Unprotect Password:="yourPassword"
            deleteRows.Delete
            .Range("K3").Value = helperData(i, 2)
            .Protect Password:="yourPassword", DrawingObjects:=True, Contents:=True, Scenarios:=True
 
Upvote 1
Solution
You must log in or register to reply here.

Forum statistics

Threads
1,215,086
Messages
6,123,040
Members
449,092
Latest member
ikke

Share this page

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
Back
Top