Run my master workbook and call another non-macro enabled workbook and do the edits to it prior to saving

Nlhicks

Active Member
Joined
Jan 8, 2021
Messages
264
Office Version
  1. 365
Platform
  1. Windows
I am getting an error on the line RngRang01 = Range("A" & Rows.Count).End(xlUp).Row and then when I move it into a with block I get an error on the line Sheet1.Range("B2:B" & RngRange01).Font.Color = vbRed. I had this code running on the workbook that it lives in and it worked marvelously now my supervisor asked that I make it a stand alone macro workbook that I can use to change the saved/shared file. I am not sure what I need to do at this point to make it work. I was able to get some of the others to work but this one is causing issues.



Sub LineUpdate1()
'Last update 11/16/2022 by NLH
'Line Update Task List
'Compares what the user enters as Changes to what is in the existing spreadsheet.
'If there is a difference: The font color changes to red and the number is updated to match the user input. Otherwise if there is no change it keeps the original formatting and information.
'It then does the math to compute the difference between what was and what is now and defines it as uprate/downrate in a table to the right.
'Then it concatenates all of the values together to paste into an email and that is in a table down below.
'This module and the next 4 (Module 3,4,5,6,7) are all pretty much the same but each one is for a new change if more than one are made.
Application.ScreenUpdating = False

Dim RngRange01 As Range
Dim Wb As Workbook
Dim LineUpdate As Worksheet, Sheet2 As Worksheet
Dim Ws As Range
Dim Rowz As Integer


Windows("WAPA-UGPR Facility Rating and SOL Record (Master).xlsm").Activate
Sheets("Line Update").Activate
Set LineUpdate = Sheets("Line Update")

'Workbooks.Open Filename:="WAPA-UGPR Facility Rating and SOL Record (Test Workbook).xlsm"
Windows("WAPA-UGPR Facility Rating and SOL Record (Test Workbook).xlsm").Activate
Sheets("Facility Ratings & SOLs (Lines)").Activate

Set Sheet1 = Sheets("Facility Ratings & SOLs (Lines)")
Set Ws = Sheet1.UsedRange
With LineUpdate
'RngRang01 = Range("A" & Rows.Count).End(xlUp).Row
With Sheet1.Range("A1")
LineUpdate.Range("J13").Value = Sheet1.Range("A2:A685").SpecialCells(xlCellTypeVisible)

If LineUpdate.Range("C11") <> LineUpdate.Range("F11") And LineUpdate.Range("F11") <> "" Then
Sheet1.Range("B2:B" & RngRange01).Font.Color = vbRed
Sheet1.Range("B2:B" & RngRange01).Value = LineUpdate.Range("F11").Value
Else
If LineUpdate.Range("F11") = "" Then
Sheet1.Range("B2:B" & RngRange01).Value = Sheet1.Range("B2:B" & RngRange01).Value
End If
End If

If LineUpdate.Range("C12") <> LineUpdate.Range("F12") And LineUpdate.Range("F12") <> "" Then
Sheet1.Range("C2:C" & RngRange01).Font.Color = vbRed
Sheet1.Range("C2:C" & RngRange01).Value = LineUpdate.Range("F12").Value
Else

If LineUpdate.Range("F12") = "" Then
Sheet1.Range("C2:C" & RngRange01).Value = Sheet1.Range("C2:C" & RngRange01).Value

End If
End If


If LineUpdate.Range("C13") <> LineUpdate.Range("F13") And LineUpdate.Range("F13") <> "" Then
Sheet1.Range("D2:D" & RngRange01).Font.Color = vbRed
Sheet1.Range("D2:D" & RngRange01).Value = LineUpdate.Range("F13").Value
Else
If Worksheets("Line Update").Range("F13") = "" Then
Sheet1.Range("D2:D" & RngRange01).Value = Sheet1.Range("D2:D" & RngRange01).Value
End If
End If


If LineUpdate.Range("C14") <> LineUpdate.Range("F14") And LineUpdate.Range("F14") <> "" Then
Sheet1.Range("E2:E" & RngRange01).Font.Color = vbRed
Sheet1.Range("E2:E" & RngRange01).Value = Worksheets("Line Update").Range("F14").Value
Else
If LineUpdate.Range("F14") = "" Then
Sheet1.Range("E2:E" & RngRange01).Value = Sheet1.Range("E2:E").Value

End If
End If

If LineUpdate.Range("C15") <> LineUpdate.Range("F15") And LineUpdate.Range("F15") <> "" Then
Sheet1.Range("F2:F").Font.Color = vbRed
Sheet1.Range("F2:F" & RngRang01).Value = LineUpdate.Range("F15").Value
Else
If LineUpdate.Range("F15") = "" Then
Sheet1.Range("F2:F" & RngRang01).Value = Sheet1.Range("F2:F" & RngRang01).Value
End If
End If

If LineUpdate.Range("C16") <> LineUpdate.Range("F16") And LineUpdate.Range("F16") <> "" Then
Sheet1.Range("G2:G" & RngRang01).Font.Color = vbRed
Sheet1.Range("G2:G" & RngRang01).Value = WLineUpdate.Range("F16").Value
Else
If LineUpdate.Range("F16") = "" Then
Sheet1.Range("G2:G" & RngRang01).Value = Sheet1.Range("G2:G" & RngRang01).Value
End If
End If

If LineUpdate.Range("C17") <> LineUpdate.Range("F17") And LineUpdate.Range("F17") <> "" Then
Sheet1.Range("H2:H" & RngRang01).Font.Color = vbRed
Sheet1.Range("H2:H" & RngRang01).Value = LineUpdate.Range("F17").Value
Else
If LineUpdate.Range("F17") = "" Then
Sheet1.Range("H2:H" & RngRang01).Value = Sheet1.Range("H2:H" & RngRang01).Value
End If
End If

If LineUpdate.Range("C18") <> LineUpdate.Range("F18") And LineUpdate.Range("F18") <> "" Then
Sheet1.Range("I2:I" & RngRang01).Font.Color = vbRed
Sheet1.Range("I2:I" & RngRang01).Value = LineUpdate.Range("F18").Value
Else
If LineUpdate.Range("F18") = "" Then
Sheet1.Range("I2:I" & RngRang01).Value = Sheet1.Range("I2:I" & RngRang01).Value
End If
End If

'Worksheets("Line Update").Activate
End With
End With

Call LineColorCells

Call DoLineMath1
Application.ScreenUpdating = True

End Sub
 
how can I provide you with what you need to get it done? It will not let me upload my workbooks to the internet nor do I think that would be a good idea even if I could.
I have shown snippets of what I am working with is there more that I could show you to help?

I will try what you suggested above and see if I can make it work. Just to let you know, I rewrote the Xfmr code with find right row and it works perfectly. Both of those codes are working.
 
Upvote 0

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Do you want me to put this code into the place where that one line was?
 
Upvote 0
I put in lngLastRow = WorksheetFunction.Max(wsUpdate.Range("A" & wsUpdate.Rows.Count).End(xlUp).Row, 2) where you you suggested I put it in and now nothing is happening.
Something did happen I just could not see it. What happened is the second row of the worksheet got the update not my visible cells.
 
Upvote 0
Here is a snapshot of what the autofilter does, it will find the exact line either by lookin at the To Substation, From Substation and Circuit number or if another layer of autofiltering is needed it asks the user to input the Bus number then it filters on that until there is only one visible row showing. So the update has to happen to that visible row not just row two or row one.
 

Attachments

  • Sheet (Facility Ratings & SOLs (Lines)).PNG
    Sheet (Facility Ratings & SOLs (Lines)).PNG
    19.4 KB · Views: 3
Upvote 0
I tried this lngLastRow = wsUpdate.Range("A" & wsUpdate.Rows.Count).End(xlUp).Row.SpecialCells(xlCellTypeVisible) and it is telling me it is an invalid qualifier
 
Upvote 0
Hi Nlhicks,

the last filled row wil be found by
VBA Code:
  lngLastRow =  wsUpdate.Range("A" & wsUpdate.Rows.Count).End(xlUp).Row
and will differ whether there are rows hidden by AutoFilter thereafter or not.

And as I left AutoFilter and filtered data out this may solve some problems:

VBA Code:
  With wsFacility
    wsUpdate.Range("J13").Value = .Range("A2:A685").SpecialCells(xlCellTypeVisible)
    For lngLooper = 11 To 18
      If wsUpdate.Cells(lngLooper, "C") <> wsUpdate.Cells(lngLooper, "F") And wsUpdate.Cells(lngLooper, "F") <> "" Then
'        .Range(.Cells(2, lngLooper - 9), .Cells(lngLastRow, lngLooper - 9)).Font.Color = vbRed
'        .Range(.Cells(2, lngLooper - 9), .Cells(lngLastRow, lngLooper - 9)).Value = wsUpdate.Cells(lngLooper, "F").Value
        .Range(.Cells(2, lngLooper - 9), .Cells(lngLastRow, lngLooper - 9)).SpecialCells(xlCellTypeVisible).Font.Color = vbRed
        .Range(.Cells(2, lngLooper - 9), .Cells(lngLastRow, lngLooper - 9)).SpecialCells(xlCellTypeVisible).Value = wsUpdate.Cells(lngLooper, "F").Value
     Else
        If wsUpdate.Cells(lngLooper, "F") = "" Then
'          .Range(.Cells(2, lngLooper - 9), .Cells(lngLastRow, lngLooper - 9)).Value = _
'              .Range(.Cells(2, lngLooper - 9), .Cells(lngLastRow, lngLooper - 9)).Value
          .Range(.Cells(2, lngLooper - 9), .Cells(lngLastRow, lngLooper - 9)).SpecialCells(xlCellTypeVisible).Value = _
              .Range(.Cells(2, lngLooper - 9), .Cells(lngLastRow, lngLooper - 9)).SpecialCells(xlCellTypeVisible).Value
        End If
      End If
    Next lngLooper
  End With

If I could not only read your postings but understand them (and maybe even read and understand the comments) I think we would be finished by now - still reworking code and I think it will take until tomorrow to finish.

Holger
 
Upvote 1
Hi Nlhicks,

the last filled row wil be found by
VBA Code:
  lngLastRow =  wsUpdate.Range("A" & wsUpdate.Rows.Count).End(xlUp).Row
and will differ whether there are rows hidden by AutoFilter thereafter or not.

And as I left AutoFilter and filtered data out this may solve some problems:

VBA Code:
  With wsFacility
    wsUpdate.Range("J13").Value = .Range("A2:A685").SpecialCells(xlCellTypeVisible)
    For lngLooper = 11 To 18
      If wsUpdate.Cells(lngLooper, "C") <> wsUpdate.Cells(lngLooper, "F") And wsUpdate.Cells(lngLooper, "F") <> "" Then
'        .Range(.Cells(2, lngLooper - 9), .Cells(lngLastRow, lngLooper - 9)).Font.Color = vbRed
'        .Range(.Cells(2, lngLooper - 9), .Cells(lngLastRow, lngLooper - 9)).Value = wsUpdate.Cells(lngLooper, "F").Value
        .Range(.Cells(2, lngLooper - 9), .Cells(lngLastRow, lngLooper - 9)).SpecialCells(xlCellTypeVisible).Font.Color = vbRed
        .Range(.Cells(2, lngLooper - 9), .Cells(lngLastRow, lngLooper - 9)).SpecialCells(xlCellTypeVisible).Value = wsUpdate.Cells(lngLooper, "F").Value
     Else
        If wsUpdate.Cells(lngLooper, "F") = "" Then
'          .Range(.Cells(2, lngLooper - 9), .Cells(lngLastRow, lngLooper - 9)).Value = _
'              .Range(.Cells(2, lngLooper - 9), .Cells(lngLastRow, lngLooper - 9)).Value
          .Range(.Cells(2, lngLooper - 9), .Cells(lngLastRow, lngLooper - 9)).SpecialCells(xlCellTypeVisible).Value = _
              .Range(.Cells(2, lngLooper - 9), .Cells(lngLastRow, lngLooper - 9)).SpecialCells(xlCellTypeVisible).Value
        End If
      End If
    Next lngLooper
  End With

If I could not only read your postings but understand them (and maybe even read and understand the comments) I think we would be finished by now - still reworking code and I think it will take until tomorrow to finish.

Holger
Thank you Holger, I pasted this code in and reran it and again my header row got changed and not the row I needed to have changed. My original code worked, can you figure out how to combine my original code with your code here and make it work. I think you solved the problem of working in the multiple workbooks but maybe we need to revert back to the line by line and column by column that I originally wrote in order for it to work. The way I had it, I would update anything in Column B with what was in Line Update Cell C8(I think) then it would update anything in column C with what was in Line Update Cell C9(I think), etc.
 
Upvote 0
Hi Nlhicks,

okay but that would have to wait until tomorrow sometime in the morning.

Holger
 
Upvote 0
Hi Nlhicks,

I'd prefer not to rebuild the code I supplied as the last version but start with the code which was presented in the opening post. I have changed some names in order to be able to compile the procedure and would ask you to run the code and see if it does what you want (I suspect myself to have made the fatal error right at the very start when modifying this procedure). If everything is fine: stay with that code as it will deliver what you want.

I put in some comments to point out what has been changed. Using With-End With clauses without referring to the objects from there just gives more codelines and does not really help as one aspect is to shorten codelines and references. And if you indent the codelines like I did it will put the code further out to the right (my setting is 2 for Tab, normal setting is 4).

VBA Code:
Sub LineUpdate1()
'Last update 11/16/2022 by NLH
'Line Update Task List
'Compares what the user enters as Changes to what is in the existing spreadsheet.
'If there is a difference: The font color changes to red and the number is updated to match the user input. Otherwise if there is no change it keeps the original formatting and information.
'It then does the math to compute the difference between what was and what is now and defines it as uprate/downrate in a table to the right.
'Then it concatenates all of the values together to paste into an email and that is in a table down below.
'This module and the next 4 (Module 3,4,5,6,7) are all pretty much the same but each one is for a new change if more than one are made.

'/// starting code for this thread
'/// changes marked by comments starting with '///
'/// HaHoBe, 20221203

Dim RngRange01 As Range
'/// Wb is dimmed but not used in this procedure
Dim Wb As Workbook
'/// changed Sheet2 to Sheet1 as that is being referenced in the code
'/// Sheet1 is a codename for a worksheet, not really a good choice for a variable
'Dim LineUpdate As Worksheet, Sheet2 As Worksheet
Dim LineUpdate As Worksheet, Sheet1 As Worksheet
'/// Ws for me is associated with Worksheet not a Range
Dim Ws As Range
'/// RowZ is dimmed but not used in this procedure
Dim Rowz As Integer

Application.ScreenUpdating = False
Windows("WAPA-UGPR Facility Rating and SOL Record (Master).xlsm").Activate
Sheets("Line Update").Activate
Set LineUpdate = Sheets("Line Update")

'Workbooks.Open Filename:="WAPA-UGPR Facility Rating and SOL Record (Test Workbook).xlsm"
Windows("WAPA-UGPR Facility Rating and SOL Record (Test Workbook).xlsm").Activate
Sheets("Facility Ratings & SOLs (Lines)").Activate

Set Sheet1 = Sheets("Facility Ratings & SOLs (Lines)")
'/// Ws is set but not used in further codelines
Set Ws = Sheet1.UsedRange
'/// a sheet is laid out to be used to shorten the code but in every codeline thereafter LineUpdate is used for a qualified range
With LineUpdate
  '/// uncommented codeline and replaced RngRang01 with RngRange01
  '/// usually a range is set  to an object and not a row given to it (that's more likely for a Long, Integer, Double etc.)
  'RngRang01 = Range("A" & Rows.Count).End(xlUp).Row
  RngRange01 = Range("A" & Rows.Count).End(xlUp).Row
  '/// a cell is laid to be used thereafter as reference but not used
  With Sheet1.Range("A1")
    LineUpdate.Range("J13").Value = Sheet1.Range("A2:A685").SpecialCells(xlCellTypeVisible)
  
    If LineUpdate.Range("C11") <> LineUpdate.Range("F11") And LineUpdate.Range("F11") <> "" Then
      Sheet1.Range("B2:B" & RngRange01).Font.Color = vbRed
      Sheet1.Range("B2:B" & RngRange01).Value = LineUpdate.Range("F11").Value
    Else
      If LineUpdate.Range("F11") = "" Then
        Sheet1.Range("B2:B" & RngRange01).Value = Sheet1.Range("B2:B" & RngRange01).Value
      End If
    End If
  
    If LineUpdate.Range("C12") <> LineUpdate.Range("F12") And LineUpdate.Range("F12") <> "" Then
      Sheet1.Range("C2:C" & RngRange01).Font.Color = vbRed
      Sheet1.Range("C2:C" & RngRange01).Value = LineUpdate.Range("F12").Value
    Else
      If LineUpdate.Range("F12") = "" Then
        Sheet1.Range("C2:C" & RngRange01).Value = Sheet1.Range("C2:C" & RngRange01).Value
      End If
    End If
  
    If LineUpdate.Range("C13") <> LineUpdate.Range("F13") And LineUpdate.Range("F13") <> "" Then
      Sheet1.Range("D2:D" & RngRange01).Font.Color = vbRed
      Sheet1.Range("D2:D" & RngRange01).Value = LineUpdate.Range("F13").Value
    Else
      If Worksheets("Line Update").Range("F13") = "" Then
        Sheet1.Range("D2:D" & RngRange01).Value = Sheet1.Range("D2:D" & RngRange01).Value
      End If
    End If
  
    If LineUpdate.Range("C14") <> LineUpdate.Range("F14") And LineUpdate.Range("F14") <> "" Then
      Sheet1.Range("E2:E" & RngRange01).Font.Color = vbRed
      Sheet1.Range("E2:E" & RngRange01).Value = Worksheets("Line Update").Range("F14").Value
    Else
      If LineUpdate.Range("F14") = "" Then
        Sheet1.Range("E2:E" & RngRange01).Value = Sheet1.Range("E2:E").Value
      End If
    End If
  
    '/// ran replace for making RngRang01 RngRange01
    If LineUpdate.Range("C15") <> LineUpdate.Range("F15") And LineUpdate.Range("F15") <> "" Then
      Sheet1.Range("F2:F").Font.Color = vbRed
      Sheet1.Range("F2:F" & RngRange01).Value = LineUpdate.Range("F15").Value
    Else
      If LineUpdate.Range("F15") = "" Then
        Sheet1.Range("F2:F" & RngRange01).Value = Sheet1.Range("F2:F" & RngRange01).Value
      End If
    End If
  
    If LineUpdate.Range("C16") <> LineUpdate.Range("F16") And LineUpdate.Range("F16") <> "" Then
      Sheet1.Range("G2:G" & RngRange01).Font.Color = vbRed
      '/// replaced WLineUpdate with LineUpdate
      'Sheet1.Range("G2:G" & RngRange01).Value = WLineUpdate.Range("F16").Value
      Sheet1.Range("G2:G" & RngRange01).Value = LineUpdate.Range("F16").Value
    Else
      If LineUpdate.Range("F16") = "" Then
        Sheet1.Range("G2:G" & RngRange01).Value = Sheet1.Range("G2:G" & RngRange01).Value
      End If
    End If
  
    If LineUpdate.Range("C17") <> LineUpdate.Range("F17") And LineUpdate.Range("F17") <> "" Then
      Sheet1.Range("H2:H" & RngRange01).Font.Color = vbRed
      Sheet1.Range("H2:H" & RngRange01).Value = LineUpdate.Range("F17").Value
    Else
      If LineUpdate.Range("F17") = "" Then
        Sheet1.Range("H2:H" & RngRange01).Value = Sheet1.Range("H2:H" & RngRange01).Value
      End If
    End If
  
    If LineUpdate.Range("C18") <> LineUpdate.Range("F18") And LineUpdate.Range("F18") <> "" Then
      Sheet1.Range("I2:I" & RngRange01).Font.Color = vbRed
      Sheet1.Range("I2:I" & RngRange01).Value = LineUpdate.Range("F18").Value
    Else
      If LineUpdate.Range("F18") = "" Then
        Sheet1.Range("I2:I" & RngRange01).Value = Sheet1.Range("I2:I" & RngRange01).Value
      End If
    End If
  
    'Worksheets("Line Update").Activate
  End With
End With

'/// commented next codeline in order to check only this code
'Call LineColorCells

'/// commented next codeline in order to check only this code
'Call DoLineMath1
Application.ScreenUpdating = True

End Sub

Ciao,
Holger
 
Upvote 1
Hi Nlhcks,

as I had worked on each of the procedures on it's own a lot of code is used more than once and the names are not really consistent. Except for LineUpdate1 this could be one way to go (introducing two new subs):

VBA Code:
Function HighestVersion(FolderName As String, _
                        Ext As String, _
                        StartFileName As String) As String
' https://www.mrexcel.com/board/threads/run-my-master-workbook-and-call-another-non-macro-enabled-workbook-and-do-the-edits-to-it-prior-to-saving.1223414/
' adapted from: https://www.mrexcel.com/board/threads/find-the-latest-version.1222956/
' finding the highest version number for files starting with a given name and type
' check for Folder before starting FSO

Dim lngCompare      As Long
Dim lngVersion      As Long
Dim objFSO          As Object
Dim objFolder       As Object
Dim objFile         As Object
Dim NewFileName     As String
Dim strVers         As String


If Right(FolderName, 1) <> Application.PathSeparator Then FolderName = FolderName & Application.PathSeparator
If Dir(FolderName, vbDirectory) = "" Then
  MsgBox "Problems for path " & FolderName, vbInformation, "Ending here"
  End
End If
Set objFSO = CreateObject("scripting.filesystemobject")
Set objFolder = objFSO.GetFolder(FolderName)
For Each objFile In objFolder.Files
  If UCase(Left(objFile.Name, Len(StartFileName))) = UCase(StartFileName) Then
    lngCompare = 0
    strVers = Trim(Mid(objFile.Name, Len(StartFileName) + 1))
    If InStr(1, strVers, ".") > 0 Then lngCompare = CLng(Left(strVers, InStr(1, strVers, ".") - 1))
    If lngCompare > lngVersion Then
      lngVersion = lngCompare
      NewFileName = objFile.Name
    End If
  End If
Next objFile
HighestVersion = NewFileName
Set objFolder = Nothing
Set objFSO = Nothing
End Function

VBA Code:
Sub GetWorkbook_Worksheet(sPath As String, _
                          sWbName As String, _
                          wbkToSet As Object, _
                          sShName As String, _
                          wksToSet As Object)

'Parameters passed:
'     sPath:    Drive and Path to the Folder for workbook
'     sWbName:  Name and Extension of workbook
'     wbkToSet: Empty Object to the workbook which should be filled withing
'     sShName:  Name of worksheet in workbook
'     wksToSet: Empty Object to the worksheet which should be filled withing

  Dim Wb          As Workbook     'object to loop through the open workbooks in the instance
  Dim blnNew      As Boolean      'to detect whether workbook is opend (active one by default then) or
                                  'was open (so must not be active one) deciding how to check for the sheetname

  blnNew = False

  If Len(sWbName) = 0 Then GoTo end_GetWbkWks
  For Each Wb In Workbooks
    If LCase(Wb.Name) = LCase(sWbName) Then
      Set wbkToSet = Wb
      Exit For
    End If
  Next Wb
  
  If wbkToSet Is Nothing Then
    If Right(sPath, 1) <> Application.PathSeparator Then sPath = sPath & Application.PathSeparator
    If Dir(sPath, vbDirectory) = "" Then GoTo end_GetWbkWks
    If Dir(sPath & sWbName) <> "" Then
      Set wbkToSet = Workbooks.Open(sPath & sWbName)
      blnNew = True
    Else
      GoTo end_GetWbkWks
    End If
  End If

  If Len(sShName) = 0 Then GoTo end_GetWbkWks
  If blnNew Then
    If Evaluate("ISREF('" & sShName & "'!A1)") Then
      Set wksToSet = wbkToSet.Sheets(sShName)
    End If
  Else
    If Evaluate("ISREF('[" & sWbName & "]" & sShName & "'!A1)") Then
      Set wksToSet = wbkToSet.Sheets(sShName)
    End If
  End If
end_GetWbkWks:

End Sub

Sub Workbook_Worksheet2Nothing(wbkToSet As Object, wksToSet As Object)

Set wksToSet = Nothing
Set wbkToSet = Nothing

End Sub

VBA Code:
Const cstrMsgTitle As String = "Ending DoLineMath1"
'

Sub MrE_1223414_1615014_DoLineMath1_New()
' https://www.mrexcel.com/board/threads/run-my-master-workbook-and-call-another-non-macro-enabled-workbook-and-do-the-edits-to-it-prior-to-saving.1223414/
' Updated: 20221202
' Reason:  Reworked Code
  Dim blnEnd            As Boolean
  Dim lngCounter        As Long
  Dim wbkData           As Workbook
  Dim wksWork           As Worksheet

  Const cstrPath        As String = "C:\Users\nhicks\Documents\Ratings\Saved Versions\"
  Const cstrWbData      As String = "WAPA-UGPR Facility Rating and SOL Record (Master).xlsm"
  Const cstrShData      As String = "Line Update"

  GetWorkbook_Worksheet cstrPath, cstrWbData, wbkData, cstrShData, wksWork

  If wbkData Is Nothing Then
    MsgBox "No Object set for '" & cstrWbData & "'. ", vbInformation, cstrMsgTitle
    blnEnd = True
    GoTo end_here
  End If
  If wksWork Is Nothing Then
    MsgBox "No Object set for '" & cstrShData & "'. ", vbInformation, cstrMsgTitle
    blnEnd = True
    GoTo end_here
  End If

  With wksWork
    'not clear what the following check should do: on my system the check returns True if all cells are empty -->
        'why clear the contents of the cells?
    '/// code changed to clear values if at least one cell shows a value
    If WorksheetFunction.CountA(.Range("F11,F13,F18,F17")) > 0 Then
      .Range("L13, M13,O13,P13") = ""
    Else
      For lngCounter = 0 To 1
        'for 0 Checked Addresses C11 and F11, Target L13
        'for 1 Checked Addresses C11 and F11, Target L13
        '/// identical cells abd both target for the same cell???
        If .Cells(11, "C").Value <> .Cells(11, "F").Value Then
          .Cells(13, "L").Value = .Cells(11, "F") - .Cells(11, "C")
        End If
        'for 0 Checked Addresses C13 and F13, Target M13
        'for 1 Checked Addresses C14 and F14, Target M13
        '/// both target for the same cell???
        If .Cells(13 + lngCounter, "C").Value <> .Cells(13 + lngCounter, "F").Value Then
          .Cells(13, "M").Value = .Cells(13, "F") - .Cells(13, "C")
        End If
        'for 0 Checked Addresses C15 and F15, Target O13
        'for 1 Checked Addresses C16 and F16, Target O13
        '/// both target for the same cell???
        If .Cells(15 + lngCounter, "C").Value <> .Cells(15 + lngCounter, "F").Value Then
          .Cells(13, "O").Value = .Cells(15, "F") - .Cells(15, "C")
        End If
        'for 0 Checked Addresses C17 and F17, Target P13
        'for 1 Checked Addresses C18 and F18, Target P13
        '/// both target for the same cell???
        If .Cells(17 + lngCounter, "C").Value <> .Cells(17 + lngCounter, "F").Value Then
          .Cells(13, "P").Value = .Cells(17, "F") - .Cells(17, "C")
        End If
      Next lngCounter
    End If
  End With
  
end_here:
  Workbook_Worksheet2Nothing wbkData, wksWork
  If blnEnd Then End
End Sub

VBA Code:
Const cstrMsgTitle As String = "Ending Line_Bold_in_Concatenate1"
'

Public Sub MrE_1223414_Line_Bold_in_Concatenate1_New()
' https://www.mrexcel.com/board/threads/run-my-master-workbook-and-call-another-non-macro-enabled-workbook-and-do-the-edits-to-it-prior-to-saving.1223414/
' Updated: 20221202
' Reason:  Reworked Code
  Dim wbkData           As Workbook
  Dim wksWork           As Worksheet
  Dim blnEnd            As Boolean

  Const cstrPath        As String = "C:\Users\nhicks\Documents\Ratings\Saved Versions\"
  Const cstrWbData      As String = "WAPA-UGPR Facility Rating and SOL Record (Master).xlsm"
  Const cstrShData      As String = "Line Update"

  GetWorkbook_Worksheet cstrPath, cstrWbData, wbkData, cstrShData, wksWork

  If wbkData Is Nothing Then
    MsgBox "No Object set for '" & cstrWbData & "'. ", vbInformation, cstrMsgTitle
    blnEnd = True
    GoTo end_here
  End If
  If wksWork Is Nothing Then
    MsgBox "No Object set for '" & cstrShData & "'. ", vbInformation, cstrMsgTitle
    blnEnd = True
    GoTo end_here
  End If
  
  With wksWork
    'assuming that the cells are all located on the same sheet
    '??? Range("Q13") is used two-times ???
    .Range("C32").Value = ("(" & .Range("L11") & " " & .Range("K13") & " " & .Range("L13") & " " & .Range("Q13") & " " & _
        "," & " " & .Range("O11") & " " & .Range("N13") & " " & .Range("O13") & " " & .Range("Q13") & ")")
    .Range("C32").Font.Bold = True
  End With

end_here:
  Workbook_Worksheet2Nothing wbkData, wksWork
  If blnEnd Then End

End Sub

VBA Code:
Const cstrMsgTitle As String = "Ending LineColorCells"
'

Sub MrE_1223414_1615014_LineColorCells_New()
' https://www.mrexcel.com/board/threads/run-my-master-workbook-and-call-another-non-macro-enabled-workbook-and-do-the-edits-to-it-prior-to-saving.1223414/
' Updated: 20221202
' Reason:  Reworked Code
  Dim blnEnd            As Boolean
  Dim lngLastRow        As Long
  Dim wbkData           As Workbook
  Dim wksWork           As Worksheet

  Const cstrPath        As String = "C:\Users\nhicks\Documents\Ratings\Saved Versions\"
  Const cstrWbData      As String = "WAPA-UGPR Facility Rating and SOL Record (Master).xlsm"
  Const cstrShData      As String = "Facility Ratings & SOLs (Lines)"

  GetWorkbook_Worksheet cstrPath, cstrWbData, wbkData, cstrShData, wksWork

  If wbkData Is Nothing Then
    MsgBox "No Object set for '" & cstrWbData & "'. ", vbInformation, cstrMsgTitle
    blnEnd = True
    GoTo end_here
  End If
  If wksWork Is Nothing Then
    MsgBox "No Object set for '" & cstrShData & "'. ", vbInformation, cstrMsgTitle
    blnEnd = True
    GoTo end_here
  End If
  
  With wksWork
    lngLastRow = .Range("B" & .Rows.Count).End(xlUp).Row
    With .Range("A2:N" & lngLastRow).SpecialCells(xlCellTypeVisible).Interior
      .Pattern = xlSolid
      .PatternColorIndex = xlAutomatic
      .ColorIndex = 34
      .TintAndShade = 0
      .PatternTintAndShade = 0
    End With
  End With

end_here:
  Workbook_Worksheet2Nothing wbkData, wksWork
  If blnEnd Then End
End Sub

VBA Code:
Const cstrMsgTitle As String = "Ending LineUpdate"
'

Sub MrE_1223414_1615014_LineUpdate_New()
' https://www.mrexcel.com/board/threads/run-my-master-workbook-and-call-another-non-macro-enabled-workbook-and-do-the-edits-to-it-prior-to-saving.1223414/
'Last update 11/16/2022 by NLH
'Line Update Task List
'Compares what the user enters as Changes to what is in the existing spreadsheet.
'If there is a difference: The font color changes to red and the number is updated to match the user input. Otherwise if there is no change it keeps the original formatting and information.
'It then does the math to compute the difference between what was and what is now and defines it as uprate/downrate in a table to the right.
'Then it concatenates all of the values together to paste into an email and that is in a table down below.
'This module and the next 4 (Module 3,4,5,6,7) are all pretty much the same but each one is for a new change if more than one are made.
' Updated: 20221202
' Reason:  Reworked Code
  Dim blnEnd            As Boolean
  Dim lngLastRow        As Long
  Dim lngLooper         As Long
  Dim strWbVersion      As String
  Dim wbkData           As Workbook
  Dim wksFrom           As Worksheet
  Dim wbkTarget         As Workbook
  Dim wksWorkOn         As Worksheet

  Const cstrPath        As String = "C:\Users\nhicks\Documents\Ratings\Saved Versions\"
  Const cstrWbData      As String = "WAPA-UGPR Facility Rating and SOL Record (Master).xlsm"
  Const cstrShData      As String = "Line Update"

  Const cstrStFileName  As String = "WAPA-UGPR Facility Rating and SOL Record (Data File)_v"
  Const cstrShFacility  As String = "Facility Ratings & SOLs (Lines)"
  
  GetWorkbook_Worksheet cstrPath, cstrWbData, wbkData, cstrShData, wksFrom

  If wbkData Is Nothing Then
    MsgBox "No Object set for '" & cstrWbData & "'. ", vbInformation, cstrMsgTitle
    blnEnd = True
    GoTo end_here
  End If
  If wksFrom Is Nothing Then
    MsgBox "No Object set for '" & cstrShData & "'. ", vbInformation, cstrMsgTitle
    blnEnd = True
    GoTo end_here
  End If
  
  '/// will find any xls, xlsb, xlsx or xlsm workbook that start with cstrStFileName
  '/// and should deliver the highest number from there
  strWbVersion = HighestVersion(cstrPath, ".xlsm", cstrStFileName)
  If Len(strWbVersion) = 0 Then
    MsgBox "Could not spot a version of " & vbCrLf & cstrStFileName & _
        vbCrLf & "in Path " & cstrPath, vbInformation, cstrMsgTitle
    blnEnd = True
    GoTo end_here
  End If
  
  GetWorkbook_Worksheet cstrPath, strWbVersion, wbkTarget, cstrShFacility, wksWorkOn

  If wbkTarget Is Nothing Then
    MsgBox "No Object set for '" & cstrWbData & "'. ", vbInformation, cstrMsgTitle
    blnEnd = True
    GoTo end_here
  End If
  If wksWorkOn Is Nothing Then
    MsgBox "No Object set for '" & cstrShData & "'. ", vbInformation, cstrMsgTitle
    blnEnd = True
    GoTo end_here
  End If
  
  lngLastRow = WorksheetFunction.Max(wksFrom.Range("A" & wksFrom.Rows.Count).End(xlUp).Row, 2)
 
  With wksWorkOn
    wksFrom.Range("J13").Value = .Range("A2:A685").SpecialCells(xlCellTypeVisible)
    For lngLooper = 11 To 18
      If wksFrom.Cells(lngLooper, "C") <> wksFrom.Cells(lngLooper, "F") And wksFrom.Cells(lngLooper, "F") <> "" Then
        .Range(.Cells(2, lngLooper - 9), .Cells(lngLastRow, lngLooper - 9)).SpecialCells(xlCellTypeVisible).Font.Color = vbRed
        .Range(.Cells(2, lngLooper - 9), .Cells(lngLastRow, lngLooper - 9)).SpecialCells(xlCellTypeVisible).Value = wksFrom.Cells(lngLooper, "F").Value
      Else
        If wksFrom.Cells(lngLooper, "F") = "" Then
          .Range(.Cells(2, lngLooper - 9), .Cells(lngLastRow, lngLooper - 9)).SpecialCells(xlCellTypeVisible).Value = _
              .Range(.Cells(2, lngLooper - 9), .Cells(lngLastRow, lngLooper - 9)).SpecialCells(xlCellTypeVisible).Value
        End If
      End If
    Next lngLooper
  End With
  
'  Call LineColorCells   'unable to test
'
'  Call DoLineMath1      'unable to test

end_here:
  Workbook_Worksheet2Nothing wbkTarget, wksWorkOn
  Workbook_Worksheet2Nothing wbkData, wksFrom
  If blnEnd Then End

End Sub

I placed each codesegment is in it's own module.

Holger
 
Upvote 1

Forum statistics

Threads
1,223,911
Messages
6,175,333
Members
452,636
Latest member
laura12345

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