Posts by TheGlovner

Public Sub HideDRows(ByRef wsTemp As Worksheet) 'Assume that as you want to call this from other workbooks the worksheet would be provided to the code
Dim lngRefColumn    As Long: lngRefColumn = 13      'Set to Column 13, or M
Dim lngStartRow     As Long: lngStartRow = 2        'I'm assuming your data starts on the second row
Dim lngEndRow       As Long: lngEndRow = GetLastRow(wsTemp, lngRefColumn) 'Use the Worksheet and Reference Column to find the last row
Dim lngWrkRow       As Long
For lngWrkRow = lngStartRow To lngEndRow
    If Trim(wsTemp.Cells(lngWrkRow, lngRefColumn)) = "D" Then
        wsTemp.Rows(lngWrkRow).EntireRow.Hidden = True
    Else
        wsTemp.Rows(lngWrkRow).EntireRow.Hidden = False
    End If
Next lngWrkRow
End Sub
'Gets the last populated row based on the worksheet and column supplied
Private Function GetLastRow(ByRef wsTemp As Worksheet, ByRef lngColumn As Long) As Long
    With wsTemp
        GetLastRow = .Cells(.Rows.Count, lngColumn).End(xlUp).Row
    End With
End Function

Private Sub CheckBox1_Click()
    Call GenericCheckBoxBehaviour(chkBoxObject)
End Sub


Private Sub GenericCheckBoxBehaviour(byref chkBoxObject as Checkbox)
    Dim wsTarget As Workbook 
    Dim wsSource As Workbook 
    Dim rngSource As Range 
    Dim rngTarget As Range 
    Dim wbname As String      
     
    With Excel.Application 
        .ScreenUpdating = False 
        .Calculation = Excel.xlCalculationManual 
    End With 
     
    wbname = "C:\\My Documents\Blotter\Master.xlsm" 
     
    Set wsSource = ActiveWorkbook 
    Set wsTarget = Workbooks.Open(wbname) 
    Worksheets("Master").Select 
    Worksheets("Master").Range("B6").Select 
     
    Set rngSource = wsSource.Sheets("Blotter").Range("B7:O7") 
    Set rngTarget = Worksheets("Master").Range("B" & (Worksheets("Master").Range("B65536").End(xlUp).Row + 1)) 
     
    If chkBoxObject.Value = True Then         
        rngSource.Copy 
        rngTarget.PasteSpecial xlPasteValues 
        wsSource.Worksheets("Blotter").Activate          
    End If 
     
    wsTarget.Close True 
     
    With Excel.Application 
        .ScreenUpdating = True 
        .Calculation = Excel.xlAutomatic 
        .CutCopyMode = False          
    End With 
     
     
End Sub

Option Explicit
 
'Loops through a defined range and deletes entire row where a value > 0 is found in column 3
Public Sub DeletePositiveRows()
    Dim wsTemp              As Worksheet: Set wsTemp = ThisWorkbook.Sheets("OutputSummary")
    Dim lngItemCol          As Long: lngItemCol = 2
    Dim lngValueCol         As Long: lngValueCol = 3
    Dim lngStartRow         As Long: lngStartRow = 2
    Dim lngEndRow           As Long: lngEndRow = GetLastRow(wsTemp, lngItemCol)  'Bases the end row on the contents of Column B (2)
    Dim lngWrkRow           As Long
    Dim lngGroupStart       As Long
    Dim lngGroupEnd         As Long
    Dim strCurrentGroupItem As String
    Dim blnDeleteGroup      As Boolean
    Dim colRowCollection    As Collection
    
    With wsTemp
        'Set the starting values
        lngWrkRow = lngStartRow
        Set colRowCollection = New Collection
        Do
            'First loop handles each item group
            lngGroupStart = lngWrkRow
            blnDeleteGroup = True
            strCurrentGroupItem = .Cells(lngWrkRow, lngItemCol)
            Do
                'Second loop handles the items within the group
                'Move through the group and check if any items are greater than zero
                If .Cells(lngWrkRow, lngValueCol) < 0 Then
                    'If an item is found greater than zero set the flag to mark it for deletion
                    blnDeleteGroup = False
                End If
                lngWrkRow = lngWrkRow + 1
            Loop Until strCurrentGroupItem <> .Cells(lngWrkRow, lngItemCol) 'Exits when it reaches the end of the current group
            lngGroupEnd = lngWrkRow - 1
            If blnDeleteGroup = True Then Call AppendToDeleteCollection(lngGroupStart, lngGroupEnd, colRowCollection)
        Loop Until lngWrkRow > lngEndRow
        
        'Check if any groups have been flagged for deletion and delete them if they are
        If colRowCollection.Count > 0 Then Call DeleteRowsFromCollection(wsTemp, colRowCollection)
        
    End With
End Sub


 'Gets the last populated row to set the limits of the loop
Private Function GetLastRow(ByRef wsTemp As Worksheet, ByRef lngColumn As Long) As Long
    With wsTemp
        GetLastRow = .Cells(.Rows.Count, lngColumn).End(xlUp).Row
    End With
End Function
'Adds all the rows in an item group to the collection to be deleted at the end
Private Sub AppendToDeleteCollection(ByRef lngGroupStart As Long, ByRef lngGroupEnd As Long, ByRef colRowCollection As Collection)
Dim lngCounter As Long
For lngCounter = lngGroupStart To lngGroupEnd
    colRowCollection.Add lngCounter
Next lngCounter
End Sub
Private Sub DeleteRowsFromCollection(ByRef wsTemp As Worksheet, ByRef colRowCollection As Collection)
Dim lngItemNumber   As Long
Dim lngRowNumber    As LoadPictureConstants
'Delete the rows in reverse order to avoid having to deal with them shifting and knocking the references out
With wsTemp
    For lngItemNumber = colRowCollection.Count To 1 Step -1
        lngRowNumber = colRowCollection.Item(lngItemNumber)
        .Rows(lngRowNumber).EntireRow.Delete
    Next lngItemNumber
End With
End Sub

Option Explicit
'Provides access to the file path provided
Sub A_ExternalWorkbookAccess(ByRef strFullPath As String, _
                             Optional ByRef blnWriteAccessRequired As Boolean = False, _
                             Optional ByRef blnSuppressAlreadyOpenMsg As Boolean = False, _
                             Optional ByRef blnSuppressEvents As Boolean = False, _
                             Optional ByRef blnUpdateLinks As Boolean = False, _
                             Optional ByRef blnReadOnly As Boolean = True, _
                             Optional ByRef strPassword As String = vbNullString, _
                             Optional ByRef strWriteResPassword As String = vbNullString, _
                             Optional ByRef varTargetWorkbook As Variant)
Dim strFilePathCheckMsg     As String
Dim wbTargetWorkbook        As Workbook
Dim blnWorkbookOpened       As Boolean
Dim blnCurrentEvents        As Boolean
Dim blnCurrentUpdating      As Boolean


    'Gets current EnableEvents/ScreenUpdating values to reapply before handing control back to calling routines
    blnCurrentEvents = Application.EnableEvents
    blnCurrentUpdating = Application.ScreenUpdating
    'Turns both off before process starts
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    'Checks the validity of the File Path String
    strFilePathCheckMsg = B_ValidFilePathCheck(strFullPath)
    
    If strFilePathCheckMsg <> "Path Exists" Then Call A_FilePathError(strFullPath, strFilePathCheckMsg, blnCurrentEvents, blnCurrentUpdating)
        
    'Check if the workbook is already open
    If B_CheckForOpenWorkbook(strFullPath, wbTargetWorkbook, blnCurrentEvents, blnCurrentUpdating) = True Then
        
        'Checks request against opened file permissions
        Call A_WriteAccessChecks(blnWriteAccessRequired, wbTargetWorkbook, strFullPath, blnCurrentEvents, blnCurrentUpdating)
        
        'Checks if the "Sheet Open" message has been suppressed
        If blnSuppressAlreadyOpenMsg = False Then
            MsgBox "The Workbook is already open in this application", vbCritical, "Workbook Open Error"
        End If
    Else
        
        'Sends the request to open the file
        Call A_OpenFile(wbTargetWorkbook, blnSuppressEvents, blnUpdateLinks, blnReadOnly, strPassword, strWriteResPassword, strFullPath)
        
        'Checks request against opened file permissions
        Call A_WriteAccessChecks(blnWriteAccessRequired, wbTargetWorkbook, strFullPath, blnCurrentEvents, blnCurrentUpdating)
        
    End If
    
    If IsMissing(varTargetWorkbook) = False Then Set varTargetWorkbook = wbTargetWorkbook
    
    'Returns ScreenUpdating and EnableEvents back to their starting value
    'before returning control to the calling routine
    Application.ScreenUpdating = blnCurrentUpdating
    Application.EnableEvents = blnCurrentEvents
    Set wbTargetWorkbook = Nothing
End Sub
'File Path error handler
'Called when there is an issue with the file path, the appropriate error message is supplied with the call
Private Sub A_FilePathError(ByRef strFullPath As String, _
                            ByRef strFilePathCheckMsg As String, _
                            ByRef blnCurrentEvents As Boolean, ByRef blnCurrentUpdating As Boolean)
                                      
Dim strMsgBoxContent    As String
    'Controls the dynamic section of the error message
    If strFilePathCheckMsg = "No file path has been supplied" Then
        strMsgBoxContent = "The following issue has been detected:" _
                           & vbNewLine & vbNewLine & _
                           "        - " & strFilePathCheckMsg _
    
    Else
        strMsgBoxContent = "You have supplied the following file path:" _
                           & vbNewLine & vbNewLine & _
                           strFullPath _
                           & vbNewLine & vbNewLine & _
                           "The following issue was detected with this file path:" _
                           & vbNewLine & vbNewLine & _
                           "        - " & strFilePathCheckMsg
    End If
                    
    'Adds the generic section of the error message
    strMsgBoxContent = "An error has occurred during processing within the Sheet Access Add-In:" _
                       & vbNewLine & vbNewLine & _
                       strMsgBoxContent _
                       & vbNewLine & vbNewLine & _
                       "Please address this issue and try again." _
                       & vbNewLine & vbNewLine & _
                       "This process will now terminate"
                           
    MsgBox strMsgBoxContent, vbCritical, "File Path Exception"
    Call A_TerminateProcess(blnCurrentEvents, blnCurrentUpdating)
    
End Sub
'If the calling routine has requested Write Permission
'but the opened sheet is in Read Only Mode then the process will be sent here
Private Sub A_WritePermissionError(ByRef wbTargetWorkbook As Workbook, _
                                   ByRef strFullPath As String, _
                                   ByRef blnCurrentEvents As Boolean, ByRef blnCurrentUpdating As Boolean)
    wbTargetWorkbook.Close
    MsgBox "An error has occurred during processing within the Sheet Access Add-In:" _
           & vbNewLine & vbNewLine & _
           "You have requested Write Permission from:" _
           & vbNewLine & vbNewLine & _
           strFullPath _
           & vbNewLine & vbNewLine & _
           "Only Read Permission is  currently available. Please check that nobody else" & _
           "is currently locked to the file and that the file properties are not set " & _
           "to read only." _
           & vbNewLine & vbNewLine & _
           "This process will now terminate.", _
           vbCritical, "Unhandled Exception Error"
    Call A_TerminateProcess(blnCurrentEvents, blnCurrentUpdating)
End Sub
'Generic error handler
'If there is no valid reason for a function to fail it will be passed here
'to confirm the function that failed for further investigation
Private Sub A_UnhandledError(ByRef strErrorLocation As String, _
                             ByRef blnCurrentEvents As Boolean, ByRef blnCurrentUpdating As Boolean)
    MsgBox "An SheetAccess_AddIn Error has occured while processing the following function:" _
           & vbNewLine & vbNewLine & _
           strErrorLocation _
           & vbNewLine & vbNewLine & _
           "Please contact a member of the VBA Working Group to investigate further." _
           & vbNewLine & vbNewLine & _
           "Ensure you supply full details of the inputs and process that has failed." _
           & vbNewLine & vbNewLine & _
           "This process will now terminate.", _
           vbCritical, "Unhandled Exception Error"
    Call A_TerminateProcess(blnCurrentEvents, blnCurrentUpdating)
End Sub
'Opens the supplied file path, disables/enables events based on instructions
'And sets the Target Workbook object
Private Sub A_OpenFile(ByRef wbTargetWorkbook As Workbook, _
                       ByRef blnSuppressEvents As Boolean, _
                       ByRef blnUpdateLinks As Boolean, _
                       ByRef blnReadOnly As Boolean, _
                       ByRef strPassword As String, _
                       ByRef strWriteResPassword As String, _
                       ByRef strFilePath As String)
    If blnSuppressEvents = True And Application.EnableEvents = True Then Application.EnableEvents = False
    If blnSuppressEvents = False And Application.EnableEvents = False Then Application.EnableEvents = True
    Workbooks.Open Filename:=strFilePath, _
                   ReadOnly:=blnReadOnly, _
                   UpdateLinks:=blnUpdateLinks, _
                   Password:=strPassword, _
                   WriteResPassword:=strWriteResPassword, _
                   IgnoreReadOnlyRecommended:=True
    Set wbTargetWorkbook = ActiveWorkbook
    
End Sub
'Controls the Write Access Permission Checks
'Independent from the main control due to the call happening from two places
Private Sub A_WriteAccessChecks(ByRef blnWriteAccessRequired As Boolean, _
                                ByRef wbTargetWorkbook As Workbook, _
                                ByRef strFullPath As String, _
                                ByRef blnCurrentEvents As Boolean, ByRef blnCurrentUpdating As Boolean)
    'If write access is required it will check for this
    If blnWriteAccessRequired = True Then
        If B_WorkbookReadOnlyCheck(wbTargetWorkbook) = True Then Call A_WritePermissionError(wbTargetWorkbook, strFullPath, blnCurrentEvents, blnCurrentUpdating)
    End If
End Sub
'Returns ScreenUpdating and EnableEvents back to their starting value before terminating the process before completion
Private Sub A_TerminateProcess(ByRef blnCurrentEvents As Boolean, ByRef blnCurrentUpdating As Boolean)
    Application.ScreenUpdating = blnCurrentUpdating
    Application.EnableEvents = blnCurrentEvents
    End
End Sub
'Checks supplied file path is valid and returns appropriate message
Function B_ValidFilePathCheck(ByRef strFullFilePath As String) As String
If Len(strFullFilePath) = 0 Then
    B_ValidFilePathCheck = "No file path has been supplied"
    Exit Function
End If
If Not Dir(strFullFilePath, vbDirectory) = vbNullString Then
    B_ValidFilePathCheck = "Path Exists"
    Exit Function
Else
    B_ValidFilePathCheck = "File path supplied does not exist (check spelling)"
    Exit Function
End If
End Function
'Checks if the workbook is already open in the application window
Private Function B_CheckForOpenWorkbook(ByRef strFilePath As String, _
                                        ByRef wbTargetWorkbook As Workbook, _
                                        ByRef blnCurrentEvents As Boolean, ByRef blnCurrentUpdating As Boolean) As Boolean
On Error GoTo ErrHandler
Dim wbTemp              As Workbook
Dim blnWorkbookOpen     As Boolean: blnWorkbookOpen = False
    'Checks all open Workbooks for a matching File Path
    For Each wbTemp In Application.Workbooks
        If wbTemp.FullName = strFilePath Then
            blnWorkbookOpen = True
            Set wbTargetWorkbook = wbTemp
            GoTo ExitHandler
        End If
    Next wbTemp
ExitHandler:
    'Passes the Temp Result back to the Function
    B_CheckForOpenWorkbook = blnWorkbookOpen
    Exit Function
ErrHandler:
    'No obvious reason for valid failures
    'Any errors will be sent to the UnhandledError Sub and the
    'Process Terminated
    Call A_UnhandledError("Z_CheckForOpenWorkbook", blnCurrentEvents, blnCurrentUpdating)
End Function
'Passes back whether the workbook is read only
Private Function B_WorkbookReadOnlyCheck(ByRef wbTargetWorkbook As Workbook)
    B_WorkbookReadOnlyCheck = wbTargetWorkbook.ReadOnly
End Function

'Loops through a defined range and deletes entire row where a value > 0 is found in column 3
Public Sub DeletePositiveRows()
Dim wsTemp      As Worksheet: Set wsTemp = ThisWorkbook.Sheets("OutputSummary")
Dim lngItemCol  As Long: lngItemCol = 2
Dim lngValueCol As Long: lngValueCol = 3
Dim lngStartRow As Long: lngStartRow = 2
Dim lngEndRow   As Long: lngEndRow = GetLastRow(wsTemp, lngItemCol)  'Bases the end row on the contents of Column B (2)
Dim lngWrkRow   As Long
With wsTemp
    lngWrkRow = lngStartRow
    Do
        If .Cells(lngWrkRow, lngValueCol) >= 0 Then
            .Rows(lngWrkRow).EntireRow.Delete
            'Deleting the row shifts eveything up so the end row needs adjusted
            'Also don't need to advance the row as the lower rows have already been brought up
            lngEndRow = lngEndRow - 1
        Else
            'Only advance the row when a row hasn't been deleted
            lngWrkRow = lngWrkRow + 1
        End If
    Loop Until lngWrkRow = lngEndRow
End With
End Sub
'Gets the last populated row to set the limits of the loop
Private Function GetLastRow(ByRef wsTemp As Worksheet, ByRef lngColumn As Long) As Long
    With wsTemp
        GetLastRow = .Cells(.Rows.Count, lngColumn).End(xlUp).Row
    End With
End Function

Private Sub IdentifyObject(ByRef objInputStep As Object, ByRef objCalculationClass As Object)
    Select Case TypeName(objCalculationClass)
        Case "GenericSum"
            Call GenericSumPassValues(objInputStep, objCalculationClass)
            Call GenericSumPerformCalculation(objCalculationClass)
        Case Else
            Stop 'Error Catching Statement
    End Select
    
End Sub
Private Sub GenericSumPassValues(ByRef objInputStep As Object, ByRef objCalculationClass As Object)
    
Dim varValues       As Variant
Dim dblValueToPass  As Double
Dim clsGenericSum   As GenericSum


Set clsGenericSum = objInputStep 'This was where I tried just to set the specific class based on the generic object but this doesn't work


    For Each varValues In objInputStep
        dblValueToPass = GetValueFromVariant(varValues)
        Call clsGenericSum.AddToValueCalculation(dblValueToPass)
    Next varValues
End Sub

Sub Botón1_Haga_clic_en() 
    Call Worksheet_Calculate
End Sub


'apply cells colors from single-cell formula dependencies/links
Private Sub Worksheet_Calculate() 


Dim Cel       As Range 
Dim RefCel  As Range 


On Error Resume Next 


     For Each Cel In ActiveSheet.UsedRange 
         If Cel.HasFormula Then 
             Set RefCel = Evaluate(Mid(Cel.Formula, 2)) 
             Cel.Interior.Color = RefCel.Interior.Color 
         End If 
     Next Cel
End Sub