VBA: Tickbox - True, creates a sheet. False, deletes the sheet - excel

I am editing an existing template in VBA. This template organises data from a "Raw Data" sheet into a "Day", "Evening" and "Night" sheet. I want to create a sheet called "Weekend", where data from "Raw Data" will be copied to if the date is not a weekday (i know how to do that bit).
However, the amount of data that runs through this template is massive, so to avoid creating a weekend sheet where the user does not need/want one I want to put in a section of code where if a tick box is ticked (True), a sheet called "Weekend" will be created (within the workbook, but inbetween existing sheets - namely inbetween a sheet called "Night" and "Graph - All Data") and when it is unticked (False) this sheet will not exist.
I thought about having this sheet to exist all the time, and to have it hidden when the tick box is unticked, however this means that the data would be still piled into it and in the interest of efficiency I would rather not have it like that.
Here is the Code I am trying to alter
Sub ToggleWindDirection()
Dim i As Long
Application.ScreenUpdating = False
If sheetArr(1) Is Nothing And LastNDRow = Empty Then
DefineLists
End If
Sheets("Raw Data").Unprotect Password:="2260"
For Each sht In sheetArr
sht.Unprotect Password:="2260"
Next
Set chtAllData = ActiveWorkbook.Charts("Graph - All Data")
With Sheets("Raw Data")
If .Range("O15").Value = True Then
'Wind direction is being used
.Range("C17:G17").Font.ColorIndex = xlAutomatic
.Range("D17").Font.ColorIndex = 9
.Range("G17").Font.ColorIndex = 9
.Range("D17").Locked = False
.Range("G17").Locked = False
.Range("F" & FirstNDRow & ":F10000").Interior.Pattern = xlNone
.Range("F" & FirstNDRow & ":F10000").Interior.PatternTintAndShade = 0
.Range("F" & FirstNDRow & ":F10000").Font.ColorIndex = xlAutomatic
Else
'Not using wind direction
.Range("C17:G17").Font.ColorIndex = 16
.Range("D17").Locked = True
.Range("G17").Locked = True
.Range("F" & FirstNDRow & ":F10000").Interior.Pattern = xlSolid
.Range("F" & FirstNDRow & ":F10000").Interior.TintAndShade = -4.99893185216834E-02
.Range("F" & FirstNDRow & ":F10000").Font.ColorIndex = 16
End If
'Addition by lewisthegruffalo 2016
Dim ws As Worksheet
If .Range("O21").Value = True Then
'create the weekend sheet
Set ws = Worksheets.Add(After:=Worksheets("Night"))
ws.Name = "Weekend"
Else
'No Weekend needed
Worksheets("Weekend").Delete
End If
End With
Sheets("Raw Data").Activate
Application.ScreenUpdating = True
End Sub
Any help would be greatly apprichiated.
Kind Regards,
lewisthegruffalo

If you want to create a new sheet using sheets.add then you can utilise the arguments in it to tell it where to put it, the msdn page has a good example at the bottom.

What you have so far? Where do you wanna call it? What checkbox shall be ticked? Please provide some code.
A general answer is this to add a new worksheet:
Dim ws As Worksheet
If Something Then
Set ws = Worksheets.Add(Before:=Worksheets("Graph - All Data"))
ws.Name = "Weekend"
'do anything you want with the ws object
End if

Related

Excel VBA to create new PivotCache and connect multiple Pivot Tables

I have a workbook with many pivot tables that are based on a range that is deleted and refreshed using VBA. Currently, to update the data source, as the last part of that sub routine, I recreate PivotCaches for each PivotTable and refresh.
I want just 6 of the tables to be linked together with one common PivotCache so they can share slicers etc and I cannot get it working.
I have looked all over for a solution to this but I keep coming up short and I have been stuck on it for a fair while now. I am reasonably new to VBA but I can usually work it out with trial and error but this one just has me stumped.
I obviously have done something wrong and any help to identify what, would be greatly appreciated.
Thanks :)
My current code is below (Note: I removed the non-related stuff from the code for ease of reading):
Sub RunReport()
On Error GoTo ErrorHandler
'############## Define Variables ##############
Dim WS_O As Worksheet 'Output sheet - report sheet
Dim WS_P As Worksheet 'Pivot table Sheet
Dim OuputRow As Integer 'First row for output of data
Dim LastRow_O As Integer 'Last used row of output sheet
Dim PivotCacheName As PivotCache
Dim PivotRange As String 'Range of data for Pivot Data Source
Dim PivotName1 As String 'Pivot Table Name Strings
Dim PivotName2 As String
Dim PivotName3 As String
Dim PivotName4 As String
Dim PivotName5 As String
Dim PivotName6 As String
'############## Modify Application Settings ##############
'Store current configuration
OriginalCalcMode = Application.Calculation
'Set configuration for fastest processing
Application.Calculation = xlManual
Application.ScreenUpdating = False
Application.EnableEvents = False
'############## Set Variable Values ##############
'Worksheets
Set WS_O = Sheets("Report") 'Output sheet - report sheet
Set WS_P = Sheets("Pivot Tables - Live Data") 'Pivot tables sheet
'Pivot Tables
PivotName1 = "PivotTable1"
PivotName2 = "PivotTable2"
PivotName3 = "PivotTable3"
PivotName4 = "PivotTable4"
PivotName5 = "PivotTable5"
PivotName6 = "PivotTable6"
'General
OutputRow = 7
'Used Ranges
LastRow_O = WS_O.Range("A" & Rows.Count).End(xlUp).Row
'############## Refresh Pivot Tables ##############
'Define Data Range
PivotRange = WS_O.Name & "!" & "A" & OutputRow - 1 & ":AM" & LastRow_O
'Error Handling
'Make sure every column in data set has a heading and is not blank
If WorksheetFunction.CountBlank(WS_O.Range("A" & OutputRow - 1 & ":AM" & LastRow_O).Rows(1)) > 0 Then
MsgBox "One or more columns in ''Report'' sheet has a blank heading;" & vbNewLine _
& "This has prevented the pivot tables from refreshing correctly." & vbNewLine & vbNewLine _
& "Please verify cells A" & OutputRow - 1 & ":AM" & OutputRow - 1 & " in ''Report'' sheet are not blank and try again.", vbCritical, "ERROR - Column Heading Missing"
GoTo EndSub
End If
'Change Pivot Data Sources to a single cache
Set PivotCacheName = ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=PivotRange, Version:=xlPivotTableVersion15)
WS_P.PivotTables(PivotName1).ChangePivotCache (PivotCacheName)
WS_P.PivotTables(PivotName2).ChangePivotCache (PivotCacheName)
WS_P.PivotTables(PivotName3).ChangePivotCache (PivotCacheName)
WS_P.PivotTables(PivotName4).ChangePivotCache (PivotCacheName)
WS_P.PivotTables(PivotName5).ChangePivotCache (PivotCacheName)
WS_P.PivotTables(PivotName6).ChangePivotCache (PivotCacheName)
'Refresh Pivot Tables
'Turn on auto calc while pivot's update
Application.Calculation = xlCalculationAutomatic
WS_P.PivotTables(PivotName1).RefreshTable
WS_P.PivotTables(PivotName2).RefreshTable
WS_P.PivotTables(PivotName3).RefreshTable
WS_P.PivotTables(PivotName4).RefreshTable
WS_P.PivotTables(PivotName5).RefreshTable
WS_P.PivotTables(PivotName6).RefreshTable
'Completion Confirmation
MsgBox "Report data has been compiled and pivot tables have been successfully refreshed.", vbInformation, "SUCCESS! - Report Compilation Complete"
'############## End Sub and Reset Application Configuration ##############
'Standard End Sub Functionality (where no undocumented error occurred)
EndSub:
Application.ScreenUpdating = False
Application.Calculation = OriginalCalcMode 'Reset calc option to what it was previously
Application.EnableEvents = True
Exit Sub
'Error Handling (where an undocumented error occurred - that is, an error without an explainatory message box)
ErrorHandler:
Application.ScreenUpdating = False
' Application.Calculation = OriginalCalcMode
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
MsgBox "An error caused this subroutine to stop working correctly." & vbNewLine _
& "Contact Administrator for assistance.", vbCritical, "ERROR - Contact Administrator"
End Sub
I was previously using this and still am for some tables I don't want using the same PivotCache:
'Create new caches for each table
WS_P.PivotTables(PivotName1).ChangePivotCache _
ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=PivotRange)
WS_P.PivotTables(PivotName2).ChangePivotCache _
ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=PivotRange)
WS_P.PivotTables(PivotName3).ChangePivotCache _
ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=PivotRange)
WS_P.PivotTables(PivotName4).ChangePivotCache _
ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=PivotRange)
WS_P.PivotTables(PivotName5).ChangePivotCache _
ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=PivotRange)
WS_P.PivotTables(PivotName6).ChangePivotCache _
ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=PivotRange)
I'm currently getting the Runtime 438 Error (Object doesn't support this property or method) here >>>
WS_P.PivotTables(PivotName1).ChangePivotCache (PivotCacheName)
EDIT: I have found a solution and added an answer below.
So, after a good nights sleep and several more hours of research, I have what I believe to be a solution.
It's probably not the best way, but it works and hasn't yet caused me any issues...
'Create New Pivot Cache from Data Range
WS_P.PivotTables(PivotName1).ChangePivotCache _
ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=PivotRange)
'Link Other Pivot Tables to same Pivot Cache
WS_P.PivotTables(PivotName2).CacheIndex = WS_P.PivotTables(PivotName1).CacheIndex
WS_P.PivotTables(PivotName3).CacheIndex = WS_P.PivotTables(PivotName1).CacheIndex
WS_P.PivotTables(PivotName4).CacheIndex = WS_P.PivotTables(PivotName1).CacheIndex
WS_P.PivotTables(PivotName5).CacheIndex = WS_P.PivotTables(PivotName1).CacheIndex
WS_P.PivotTables(PivotName6).CacheIndex = WS_P.PivotTables(PivotName1).CacheIndex
I'm still not sure why the other way wasn't working so would still appreciate some feedback, if anyone has any as this method does prohibit me attaching slicers to all pivot tables (I have to leave the first one out).

Using Excel VBA to retrieve data from multiple MS Project Files

I have ran into an automation issue that I cannot seem to figure out.
Currently, I have a worksheet,("Project") that contains data in columns "A"(Project Name) & "B"(Project File Location).
Column "B" contains the string location of each MS Project file.
My VBA macro loops through column "B" and opens each MS Project file and copies a task with the .SelectTaskField method and then copies it back into column "E" of the worksheet.
The first 2 projects loop through without any issues, however, on the 3rd project, I receive the Run-time error '1004': An unexpected error occurred with the method.
I co-worker and I have poured through the code and the MS Project Files to see if there are any differences in the data and we cannot find any differences.
Below is a copy of the code that I have been using.
Just wanted to see if anyone else has had similar issues. I have found that MS Project does not like to be manipulated like Excel or Word.
Any help would be greatly appreciated.
Sub Test()
Dim ws As Worksheet
Set ws = Worksheets("Projects")
Dim lrow As Long
lrow = Range("B" & Rows.Count).End(xlUp).Row
'Turns off updates and alerts
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'Select Daily Field Reports and clear worksheet
ws.Range("E2:E" & lrow).ClearContents
'Opens MS Project
Set objproject = CreateObject("MSProject.Project")
'This keeps MS Project invisible. If you want to see it, change to "True"
objproject.Application.Visible = True
Dim oproject As Range
'This cycles through the range and gathers the data for each project
For Each oproject In Range("B2:B" & lrow)
Set objproject = CreateObject("MSProject.Project")
oproject.Select
objproject.Application.FileOpen Selection
objproject.Application.Visible = True
objproject.Application.SelectTaskField Row:=1, Column:="Percent Complete", RowRelative:=False 'The column name must match. This is the only issue that I have uncovered.
objproject.Application.EditCopy
ws.Select
Dim lastrow As Long
lastrow = ws.Cells(Rows.Count, "E").End(xlUp).Row + 1
Dim Rng As Range
Set Rng = ws.Range("E" & lastrow)
'Rng.PasteSpecial xlPasteFormats
Rng.PasteSpecial xlPasteValues
objproject.Application.Quit
Next oproject
'Turns updates and alerts back on
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'Closes MS Project
objproject.Application.Quit
End Sub
Using the SelectTaskField method presumes the file was saved in a task view and that the column you want is in the table of the view. Better to get the values you need directly from the Task object.
It appears you are looking for the % Complete value from the first task. In that case use this:
objproject.ActiveProject.Tasks(1).PercentComplete
Here's how it could work in your code. I took the liberty of simplifying it a bit:
Sub Test()
Dim ws As Worksheet
Set ws = Worksheets("Projects")
Dim lrow As Long
lrow = Range("B" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = True
Application.DisplayAlerts = True
ws.Range("E2:E" & lrow).ClearContents
Dim objproject As MSProject.Application
Set objproject = CreateObject("MSProject.Application")
objproject.Application.Visible = True
Dim oproject As Range
For Each oproject In Range("B2:B" & lrow)
objproject.FileOpen Name:=oproject.Value, ReadOnly:=True
oproject.Offset(, 3) = objproject.ActiveProject.Tasks(1).PercentComplete
objproject.FileCloseEx
Next oproject
Application.ScreenUpdating = True
Application.DisplayAlerts = True
objproject.Quit
End Sub
Note that it is more straight-forward to get a reference to the application object rather than a child of that object: CreateObject("MSProject.Application") is preferable to CreateObject("MSProject.Project").

VBA - Main worksheet to add values across other new not yet created worksheets across multilpe ranges

I'm pretty new to VBA and love to challenge myself, but am at a loss on this project however.
I have a workbook that has quite a few tabs used for various calculations and summations. The "PDP Base" main tab takes all "PDP BaseX" tabs and adds all values for the same cell across all "PDP BaseX" tabs into the main one. This is easy to handle manually when there are only 5 or so "PDP BaseX" tabs, but if there are potentially many tabs to add together (10+), combing through each is a pain. This is made worse if there are multiple cases to add formulas to (PNP;PBP;PUD;PBL - with each having a Base and Sens modifier).
Each new "PDP BaseX" tab is copy pasted from a template ran by other code (not yet finished) with a new "X+1" value, and so I don't want to just copy paste a formula adding the new tab into the main tab.
The end result will have code for all the main tabs of each category, but if I can get one main tab to do what I want, I can go from there.
Below is some code that I feel is close, but it loops to infinity somewhere in there and won't move pass initial cell B29 (getting overflow into PDP Base B29 when result should be lets say 10 for example; PDP Base1 B29 = 2; PDP Base2 B29 = 6; PDP Base3 B29 = 4)
Private Sub Worksheet_Calculate()
Dim ws As Worksheet, mainws As Worksheet
Dim rng As Range, mainrng As Range
Dim x As Single, y As Single
Dim tVar As Double
Set mainws = ActiveWorkbook.Worksheets("PDP Base")
With mainws
For y = 2 To 4
For x = 29 To 43
For Each ws In ActiveWorkbook.Worksheets
If ws.Name Like "PDP Base*" And ws.CodeName <> "PDPBase" Then
'the main tab has a codename assigned to it to not add itself
With ws
With .Range(Cells(x, y))
tVar = tVar + .Range(Cells(x, y)).Value
End With
End With
End If
Next ws
Set mainrng = Cells(x, y)
mainrng.Value = tVar
tVar = 0
Next x
Next y
End With
End Sub
Would someone be able to shed some insight into this? Thank you!
Untested but should do what you want:
Private Sub Worksheet_Calculate()
Const MAIN_WS_NAME As String = "PDP Base" 'use a constant for fixed values
Dim ws As Worksheet, mainws As Worksheet, wb As Workbook
Dim x As Long, y As Long 'Long not Single
Dim tVar As Double
Set wb = ActiveWorkbook
Set mainws = wb.Worksheets(MAIN_WS_NAME)
For y = 2 To 4
For x = 29 To 43
tVar = 0
For Each ws In wb.Worksheets
If ws.Name Like MAIN_WS_NAME & "*" And ws.Name <> MAIN_WS_NAME Then
tVar = tVar + ws.Cells(x, y).Value
End If
Next ws
mainws.Cells(x, y).Value = tVar
Next x
Next y
End Sub
Its been a bit since I posted the original question, but I've gotten much further since then and just wanted to post my progress for others to use incase they need something similar.
There is still a lot of cleaning that could be done, and its not finished, but the basic idea works really really well. The code takes several codenamed (not tab names; allows users to change the tab name to something different) main sheets and loops through each, adding formulas that dynamically add cells from similarly named subsheets into the main sheet across multiple blocks of cells.
Also wanted to thank the original answer again provided by Tim Williams as that helped me tremendously to get going in the right direction and is the foundation to the code below.
Use at your own risk. I hear CodeNames and using VBProject type of codes can give you a bad day if they break.
Main Code Below
Public Sub Sheet_Initilization()
Dim ws As Worksheet, mainws As Worksheet, wb As Workbook
Dim codename As String
Dim mainwsname As String
Set wb = ActiveWorkbook
'block code to run code smoother
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
'PLACEHOLDER FOR LATER USE CaseNames = Array("PDPBase", "PDPSens", "PBPBase", "PBPSens", "PNPBase", "PNPSens", "PUDBase", "PUDSens")
CaseNames = Array("PDPBase", "PBPBase", "PNPBase", "PUDBase") 'main 4 cases, more to come
For Each c In CaseNames 'cycle through each "Main" case sheet
codename = c
Set mainws = wb.Sheets(CN(wb, codename)) 'calls function to retrieve code name of the main case sheet
'allows users to change main case tab names without messing up the codes
'must change security settings to use, looking into alternatives
mainwsname = mainws.Name 'probably could do without with some optimization
For Each b In Range("InputAdditionCells").Cells 'uses named range of multiple blocks of cells, B29:D34 M29:O43 I53:J68 for example
'cycles through each cell in every block
mainws.Range(b.Address).Formula = "=" 'initial formula
For Each ws In wb.Worksheets 'cycles through each sheet
If ws.Name Like mainwsname & "*" And ws.Name <> mainwsname Then 'finds similarily named sub sheets (PDP Base 1, PDP Base 2...etc)
', but won't use the main sheet (PDP Base)
If b.Address Like "$Y*" Then 'special column to use different offset formula
mainws.Range(b.Address).Formula = mainws.Range(b.Address).Formula & "+'" & ws.Name & "'!" & b.Offset(0, 4).Address
Else
mainws.Range(b.Address).Formula = mainws.Range(b.Address).Formula & "+'" & ws.Name & "'!" & b.Address
End If
End If
Next ws
Next b
For Each d In Range("InputWeightedCells").Cells 'same idea as before, different main formula (weighted average)
mainws.Range(d.Address).Formula = "="
For Each ws In wb.Worksheets
If ws.Name Like mainwsname & "*" And ws.Name <> mainwsname Then
If d.Address Like "*$68" Then 'special row to use different offset formula
mainws.Range(d.Address).Formula = mainws.Range(d.Address).Formula & "+('" & ws.Name & "'!" & d.Address _
& "*'" & ws.Name & "'!" & d.Offset(-21, 23).Address & ")"
Else
mainws.Range(d.Address).Formula = mainws.Range(d.Address).Formula & "+('" & ws.Name & "'!" & d.Address _
& "*'" & ws.Name & "'!" & d.Offset(-24, 23).Address & ")"
End If
End If
Next ws
Next d
MsgBox (mainwsname) 'DELETE; makes sure code is running properly/codebreak without using the break feature
Next c
'reactivate original block code
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub 'cool beans
Function that's called (need to change the Macro settings in the trust center settings from excel options to run). Once again use at your own risk.
Function CN(wb As Workbook, codename As String) As String
CN = wb.VBProject.VBComponents(codename).Properties("Name").Value
End Function

excel vba: Run-time error '438'

Using code from the spreadsheet guru to loop through files in a folder and perform a set task on them, seems to be working properly. Where I may have made a mistake is the set task portion of the code.
Using Excel 2010.
sourcewb = ActiveWookbook
sourcefn = ActiveWorkbook.Name
masterwb = ThisWorkbook
masterwb.Activate
lr = ActiveSheet.ListObjects("DataTbl").ListRows.Count
If ActiveSheet.ListObjects("DataTbl").DataBodyRange(lr, 1).Value = "" Then
sourcewb.Activate
ActiveSheet.ListObjects("IntermidateTbl").DataBodyRange.Copy
masterwb.Activate
ActiveSheet.ListObjects("DataTbl").DataBodyRange(lr, 1).Select
Selection.Paste
newlr = ActiveSheet.ListObjects("DataTbl").ListRows.Count
Range(ActiveSheet.ListObjects("DataTbl").DataBodyRange(lr, 8), _
ActiveSheet.ListObjects("DataTbl").DataBodyRange(newlr, 8)) = "" & sourcefn & ""
Else
ActiveSheet.ListObjects("DataTbl").ListRows.Add AlwaysInsert:=True
sourcewb.Activate
ActiveSheet.ListObjects("IntermidateTbl").DataBodyRange.Copy
masterwb.Activate
ActiveSheet.ListObjects("DataTbl").DataBodyRange(lr + 1, 1).Select
Selection.Paste
newlr = ActiveSheet.ListObjects("DataTbl").ListRows.Count
Range(ActiveSheet.ListObjects("DataTbl").DataBodyRange(lr + 1, 8), _
ActiveSheet.ListObjects("DataTbl").DataBodyRange(newlr, 8)) = "" & sourcefn & ""
End If
There are more than a few errors, I'll try to help with a few.
You are trying to set sourcewb, which is a Workbook object, so you need to change:
sourcewb = ActiveWookbook
To:
Set sourcewb = ActiveWookbook
(the same goes for Set masterwb = ThisWorkbook).
Next, masterwb.Activate, you don't need to Activate the workbook, and it's also safer to also set reference to the sheet you want, you can also add the With statement, and use something like:
With masterwb.Worksheets("SheetName")
lr = .ListObjects("DataTbl").ListRows.Count ' number of rows in "DataTbl" table
You can also set an Object to your ListObjects.
Dim DataTbl As ListObject
Set DataTbl = masterwb.Worksheets("SheetName").ListObjects("DataTbl")
So later on, you can access it's properties much easier (and "cleaner").
For example:
lr = DataTbl.ListRows.Count ' <-- get the rows count of the table
and:
If DataTbl.DataBodyRange(lr, 1).Value = "" Then
And so on, you have way too many places where you Activate the 2 workbooks, and later use ActiveSheet and Selection.
If you describe better what you are trying to achieve, we can help you achieve it in a more reliable way.

Excel VBA - hide rows on sheet load

In the interest of clarity, I've wiped the original question and am re-posting.
Scenario:
Source workbook has multiple pages, front page of book has a query/extract function to create a new book with some pre-entered data using a template from one of the sheets in the source book.
Requirements:
Phase 1: Extract function needs to set all rows beyond row 6 as hidden where the data in column A = HC.
First (and so far working) draft of that code as follows:
Sub Extract()
Dim wbkOriginal As Workbook
Set wbkOriginal = ActiveWorkbook
'sets site name and site ID into the estate page to be extracted
Worksheets(Sheet11.CmbSheet.Value).Range("B3").Value = Worksheets("front page").Range("E6")
Worksheets(Sheet11.CmbSheet.Value).Range("D3").Value = Worksheets("front page").Range("N6")
Worksheets(Sheet11.CmbSheet.Value).Range("F3").Value = Worksheets("front page").Range("K6")
'hiding all rows that being with HC apart from row 6 which is the starting row
'code to be added to the individual estate sheets to unhide each row after status column filled
'on a row by row basis - as the hiding is for HC rows only, the section headers will remain visible
'may have to code around that on the sheet itself
BeginRow = 7
EndRow = 300
ChkCol = 1
For RowCnt = BeginRow To EndRow
If Worksheets(Sheet11.CmbSheet.Value).Cells(RowCnt, ChkCol).Value Like "HC" Then
Worksheets(Sheet11.CmbSheet.Value).Cells(RowCnt, ChkCol).EntireRow.Hidden = True
End If
Next RowCnt
' copies sheet name from combo box into new document, saves it with site name,
' site id and current date into user profile desktop folder for ease of access
' with new HEAT, worth investigating if sheet can be saved directly to a call ID folder?
With ActiveWorkbook.Sheets(Sheet11.CmbSheet.Value)
.Copy
ActiveWorkbook.SaveAs _
"C:\temp\" _
& .Cells(3, 2).Text _
& " " _
& Format(Now(), "DD-MM-YY") _
& ".xlsm", _
xlOpenXMLWorkbookMacroEnabled, , , , False
End With
'code to close the original workbook to prevent accidental changes etc
Application.DisplayAlerts = False
wbkOriginal.Close
Application.DisplayAlerts = True
End Sub
Phase 2: Each row that starts with HC, has a drop down in column E. That drop down has 3 options, 'Complete' 'Incomplete' and 'Not Required'
Task: When the user selects and clicks on an entry, the sheet needs to do the following
Unhide the next row
Enter the current windows username into column I
Enter the current time into column J
Prototype code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ChangedCell As Object
Dim lRow As Long
For Each ChangedCell In Target
If ChangedCell.Column = 5 And ChangedCell <> "" Then
lRow = ChangedCell.Row + 1
lRow.Hidden = False
Cells(lRow, 8) = Environ("USERNAME")
Cells(lRow, 9) = "HH:MM"
End If
Next
End Sub
Problem:
Compile error: Invalid Qualifier, referring to the lRow.Hidden = False line,
Tried to declare it as an object instead, thinking that would allow me to spec it that way instead, but no joy to be had.
As ever, any guidance from the community would be greatly appreciated.
Many thanks.
Rob.
Sub Extract()
Dim wbkOriginal As Workbook
Set wbkOriginal = ActiveWorkbook
'sets site name and site ID into the estate page to be extracted
Worksheets(Sheet11.CmbSheet.Value).Range("B3").Value = Worksheets("front page").Range("E6")
Worksheets(Sheet11.CmbSheet.Value).Range("D3").Value = Worksheets("front page").Range("N6")
Worksheets(Sheet11.CmbSheet.Value).Range("F3").Value = Worksheets("front page").Range("K6")
'hiding all rows that being with HC apart from row 6 which is the starting row
'code to be added to the individual estate sheets to unhide each row after status column filled
'on a row by row basis - as the hiding is for HC rows only, the section headers will remain visible
'may have to code around that on the sheet itself
BeginRow = 7
EndRow = 300
ChkCol = 1
For RowCnt = BeginRow To EndRow
If Worksheets(Sheet11.CmbSheet.Value).Cells(RowCnt, ChkCol).Value <> "" Then
Worksheets(Sheet11.CmbSheet.Value).Cells(RowCnt, ChkCol).EntireRow.Hidden = True
End If
Next RowCnt
' copies sheet name from combo box into new document, saves it with site name,
' site id and current date into user profile desktop folder for ease of access
' with new HEAT, worth investigating if sheet can be saved directly to a call ID folder?
With ActiveWorkbook.Sheets(Sheet11.CmbSheet.Value)
.Copy
ActiveWorkbook.SaveAs _
"C:\temp\" _
& .Cells(3, 2).Text _
& " " _
& Format(Now(), "DD-MM-YY") _
& ".xlsm", _
xlOpenXMLWorkbookMacroEnabled, , , , False
End With
'code to close the original workbook to prevent accidental changes etc
Application.DisplayAlerts = False
wbkOriginal.Close
Application.DisplayAlerts = True
End Sub

Resources