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
 
I tried doing (lngLastRow-(1-9), lngColumn(-1-9) in every combination to no avail
 
Upvote 0

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
The Red Bold section of code is Getting the Run-time error 1004 message Application-defined or object-defined error.

Const cstrMsgTitle As String = "Ending XfmrUpdate"
'

Sub XfmrUpdate1()
' Run my master workbook and call another non-macro enabled workbook and do the edits to it prior to saving
'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: 20221205
'
Dim blnEnd As Boolean
Dim lngLastRow As Long
Dim lngLooper As Long
Dim lngColumn 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 = "Xfmr Update"

Const cstrStFileName As String = "WAPA-UGPR Facility Rating and SOL Record (Data File)_v"
Const cstrShFacility As String = "Facility Ratings & SOLs (Xfmrs)"

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

With wksWorkOn
lngColumn = 3 'representing column number 3 (C), will get augmented before the next row number
For lngLooper = 8 To 23
Debug.Print Rows.Count

With .Cells(lngLastRow, lngColumn)
If wksFrom.Cells(lngLooper, "D") <> wksFrom.Cells(lngLooper, "E") And wksFrom.Cells(lngLooper, "E") <> "" Then
.Font.Color = vbRed
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ColorIndex = 34
.TintAndShade = 0
.PatternTintAndShade = 0
End With
.Value = wksFrom.Cells(lngLooper, "E").Value
Else
If wksFrom.Cells(lngLooper, "E") = "" Then
.Value = .Value
End If
End If
End With
lngColumn = lngColumn + 1
Next lngLooper
End With

Call DoXfmrMath1 'commented out for test

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

End Sub
 
Upvote 0
Run-time error 1004 message Application-defined or object-defined error
 
Upvote 0
WAPA-UGPR Facility Rating and SOL Record (Master).xlsm
BCDEFGHIJKLMNOPQRSTUVW
1
2
3From Substation:Armour
4Transformer ID:KY1A
5
6Current RatingChangesUpdated
7
8PRIMARY / SECONDARY Summer Normal4545Delta Value
9Limiting Element#REF!SummerWinter
10PRIMARY / SECONDARY Summer Emergency50500SubstationXfmr IDNormalEmergencyNormalEmergency
11Limiting Element#REF!ArmourAR KY1APrimary/SecondaryUprate3.3-2.1Uprate3.3-2.1
12TERTIARY Summer Normal41.7453.3TertiaryUprate3.3-2.1Uprate3.3-2.1
13Limiting Element45#REF!Primary/SecondaryDownrateDownrate
14TERTIARY Summer Emergency52.150TertiaryDownrateDownrate
15Limiting Element#REF!Primary/SecondaryDownrateDownrate
16PRIMARY / SECONDARY Winter Normal41.745TertiaryDownrateDownrate
17Limiting Element#REF!Primary/SecondaryDownrateDownrate
18PRIMARY / SECONDARY Winter Emergency52.150TertiaryDownrateDownrate
19Limiting Element#REF!
20PRIMARY / SECONDARY Winter Emergency41.745
21Limiting Element45#REF!
22TERTIARY Winter Normal52.150
23Limiting Element#REF!
24
25
26
27
28
29
30
31Summary of Updates:
32● Armour+AR KY1A
33
34(Primary/Secondary : -2.1 3.3 MVA, 3.3 -2.1 MVA)
35(Tertiary : Uprate 3.3 MVA, -2.1 3.3 MVA)
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
Xfmr Update
Cell Formulas
RangeFormula
E9E9=INDEX(#REF!,SMALL(IF(ISNUMBER((SEARCH('Xfmr Update'!B3,#REF!))*(SEARCH('Xfmr Update'!B4,#REF!))),MATCH(ROW(#REF!),ROW(#REF!)),""),ROWS(#REF!)),COLUMNS(#REF!))
F10,F12F10=E10-D10
E11E11=INDEX(#REF!,SMALL(IF(ISNUMBER((SEARCH('Xfmr Update'!B3,#REF!))*(SEARCH('Xfmr Update'!B4,#REF!))),MATCH(ROW(#REF!),ROW(#REF!)),""),ROWS(#REF!)),COLUMNS(#REF!))
E13E13=INDEX(#REF!,SMALL(IF(ISNUMBER((SEARCH('Xfmr Update'!B3,#REF!))*(SEARCH('Xfmr Update'!B4,#REF!))),MATCH(ROW(#REF!),ROW(#REF!)),""),ROWS(#REF!)),COLUMNS(#REF!))
E15E15=INDEX(#REF!,SMALL(IF(ISNUMBER((SEARCH('Xfmr Update'!B3,#REF!))*(SEARCH('Xfmr Update'!B4,#REF!))),MATCH(ROW(#REF!),ROW(#REF!)),""),ROWS(#REF!)),COLUMNS(#REF!))
E17E17=INDEX(#REF!,SMALL(IF(ISNUMBER((SEARCH('Xfmr Update'!B3,#REF!))*(SEARCH('Xfmr Update'!B4,#REF!))),MATCH(ROW(#REF!),ROW(#REF!)),""),ROWS(#REF!)),COLUMNS(#REF!))
O11:O18,R11:R18O11=IF(P11>0,"Uprate","Downrate")
E19E19=INDEX(#REF!,SMALL(IF(ISNUMBER((SEARCH('Xfmr Update'!B3,#REF!))*(SEARCH('Xfmr Update'!B4,#REF!))),MATCH(ROW(#REF!),ROW(#REF!)),""),ROWS(#REF!)),COLUMNS(#REF!))
E21E21=INDEX(#REF!,SMALL(IF(ISNUMBER((SEARCH('Xfmr Update'!B3,#REF!))*(SEARCH('Xfmr Update'!B4,#REF!))),MATCH(ROW(#REF!),ROW(#REF!)),""),ROWS(#REF!)),COLUMNS(#REF!))
C8C8='C:\Users\nhicks\Documents\Ratings\Saved Versions\[WAPA-UGPR Facility Rating and SOL Record (Data File)_v163.xlsm]Facility Ratings & SOLs (Xfmrs)'!$C$1
C9C9='C:\Users\nhicks\Documents\Ratings\Saved Versions\[WAPA-UGPR Facility Rating and SOL Record (Data File)_v163.xlsm]Facility Ratings & SOLs (Xfmrs)'!$D$1
C10C10='C:\Users\nhicks\Documents\Ratings\Saved Versions\[WAPA-UGPR Facility Rating and SOL Record (Data File)_v163.xlsm]Facility Ratings & SOLs (Xfmrs)'!$E$1
C11C11='C:\Users\nhicks\Documents\Ratings\Saved Versions\[WAPA-UGPR Facility Rating and SOL Record (Data File)_v163.xlsm]Facility Ratings & SOLs (Xfmrs)'!$F$1
C12C12='C:\Users\nhicks\Documents\Ratings\Saved Versions\[WAPA-UGPR Facility Rating and SOL Record (Data File)_v163.xlsm]Facility Ratings & SOLs (Xfmrs)'!$G$1
C13C13='C:\Users\nhicks\Documents\Ratings\Saved Versions\[WAPA-UGPR Facility Rating and SOL Record (Data File)_v163.xlsm]Facility Ratings & SOLs (Xfmrs)'!$H$1
C14C14='C:\Users\nhicks\Documents\Ratings\Saved Versions\[WAPA-UGPR Facility Rating and SOL Record (Data File)_v163.xlsm]Facility Ratings & SOLs (Xfmrs)'!$I$1
C15C15='C:\Users\nhicks\Documents\Ratings\Saved Versions\[WAPA-UGPR Facility Rating and SOL Record (Data File)_v163.xlsm]Facility Ratings & SOLs (Xfmrs)'!$J$1
C16C16='C:\Users\nhicks\Documents\Ratings\Saved Versions\[WAPA-UGPR Facility Rating and SOL Record (Data File)_v163.xlsm]Facility Ratings & SOLs (Xfmrs)'!$K$1
C17,C19C17='C:\Users\nhicks\Documents\Ratings\Saved Versions\[WAPA-UGPR Facility Rating and SOL Record (Data File)_v163.xlsm]Facility Ratings & SOLs (Xfmrs)'!$L$1
C18,C20C18='C:\Users\nhicks\Documents\Ratings\Saved Versions\[WAPA-UGPR Facility Rating and SOL Record (Data File)_v163.xlsm]Facility Ratings & SOLs (Xfmrs)'!$M$1
C21C21='C:\Users\nhicks\Documents\Ratings\Saved Versions\[WAPA-UGPR Facility Rating and SOL Record (Data File)_v163.xlsm]Facility Ratings & SOLs (Xfmrs)'!$N$1
C22C22='C:\Users\nhicks\Documents\Ratings\Saved Versions\[WAPA-UGPR Facility Rating and SOL Record (Data File)_v163.xlsm]Facility Ratings & SOLs (Xfmrs)'!$O$1
C23C23='C:\Users\nhicks\Documents\Ratings\Saved Versions\[WAPA-UGPR Facility Rating and SOL Record (Data File)_v163.xlsm]Facility Ratings & SOLs (Xfmrs)'!$P$1
E23E23=INDEX(#REF!,SMALL(IF(ISNUMBER((SEARCH('Xfmr Update'!B3,#REF!))*(SEARCH('Xfmr Update'!B4,#REF!))),MATCH(ROW(#REF!),ROW(#REF!)),""),ROWS(#REF!)),COLUMNS(#REF!))
C32C32=CONCAT(D30," ",L11, "+",M11)
Cells with Conditional Formatting
CellConditionCell FormatStop If True
C32:J41Expression=OR(C32="",C32="____")textNO
S11:T18Expression=OR(S11="",S11="____")textNO
P11:Q18Expression=OR(P11="",P11="____")textNO
L11:M18Expression=OR(L11="",L11="____")textNO
D8:D23Expression=OR(D8="",D8="____")textNO
D4Expression=OR(D4="",D4="____")textNO
D3Expression=OR(D3="",D3="____")textNO
 
Upvote 0
WAPA-UGPR Facility Rating and SOL Record (Data File)_v163.xlsm
ABCDEFGHIJKLMNOPQR
1FROM Substation NameTransformer IDPRIMARY / SECONDARY Summer NormalLimiting ElementPRIMARY / SECONDARY Summer EmergencyLimiting ElementTERTIARY Summer NormalLimiting ElementTERTIARY Summer EmergencyLimiting ElementPRIMARY / SECONDARY Winter NormalLimiting ElementPRIMARY / SECONDARY Winter EmergencyLimiting ElementTERTIARY Winter NormalLimiting ElementTERTIARY Winter EmergencyLimiting Element
3ArmourAR KY1A45#REF!5041.752.141.752.141.752.1
Facility Ratings & SOLs (Xfmrs)
 
Upvote 0
I am not sure how to get the code pasted in here via XL2BB but here is how it has adapted recently, and I am still getting errors:

Const cstrMsgTitle As String = "Ending XfmrUpdate"
'

Sub XfmrUpdate1()
' Run my master workbook and call another non-macro enabled workbook and do the edits to it prior to saving
'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: 20221205
'
Dim blnEnd As Boolean
Dim lngLastRow As Long
Dim lngLooper As Double
Dim lngColumn 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\Owner\Documents\Saved Versions\"
Const cstrWbData As String = "WAPA-UGPR Facility Rating and SOL Record (Master).xlsm"
Const cstrShData As String = "Xfmr Update"

Const cstrStFileName As String = "WAPA-UGPR Facility Rating and SOL Record (Data File)_v"
Const cstrShFacility As String = "Facility Ratings & SOLs (Xfmrs)"

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
' With wksWorkOn
' lngLastRow = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(1).Row
' wksFrom.Range("L11").Value = .Range("A2:A150").SpecialCells(xlCellTypeVisible).Cells.Value
' For lngLooper = 8 To 23
' With .Cells(lngLastRow, lngLooper - 9)
' If wksFrom.Cells(lngLooper, "D") <> wksFrom.Cells(lngLooper, "E") And wksFrom.Cells(lngLooper, "E") <> "" Then
' .Font.Color = vbRed
' With .Range("A" & lngLastRow & ":N" & lngLastRow).Interior
' .Pattern = xlSolid
' .PatternColorIndex = xlAutomatic
' .ColorIndex = 34
' .TintAndShade = 0
' .PatternTintAndShade = 0
' End With
' .Value = wksFrom.Cells(lngLooper, "E").Value
' Else
' If wksFrom.Cells(lngLooper, "E") = "" Then
' .Value = .Value
' End If
' End If
' End With
' Next lngLooper
' End With
With wksWorkOn
lngLastRow = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(1).Row
wksFrom.Range("L11").Value = .Range("A2:A186").SpecialCells(xlCellTypeVisible).Cells.Value
wksFrom.Range("M11").Value = .Range("B2:B186").SpecialCells(xlCellTypeVisible).Cells.Value
lngColumn = 3 'representing column number 3 (C), will get augmented before the next row number
For lngLooper = 8 To 23
Debug.Print Rows.Count
With .Cells(lngLastRow, lngLooper - 6)
If wksFrom.Cells(lngLooper, "D") <> wksFrom.Cells(lngLooper, "E") And wksFrom.Cells(lngLooper, "E") <> "" Then
.Font.Color = vbRed
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ColorIndex = 34
.TintAndShade = 0
.PatternTintAndShade = 0
End With
.Value = wksFrom.Cells(lngLooper, "E").Value
Else
If wksFrom.Cells(lngLooper, "E") = "" Then
.Value = .Value
End If
End If
End With
lngColumn = lngColumn + 1
Next lngLooper
' Next lngColumn
End With

Call DoXfmrMath1 'commented out for test

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

End Sub
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
Function HighestVersion(FolderName As String, _
Ext As String, _
StartFileName As String) As String
' Run my master workbook and call another non-macro enabled workbook and do the edits to it prior to saving
' adapted from: Find the latest version

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

Sub DoXfmrMath1()

Dim i As Integer
Dim wb As Workbook
Dim wbFacility As Workbook
Dim Update As Worksheet


Const cstrWbFacility As String = "WAPA-UGPR Facility Rating and SOL Record (Master).xlsm"
Const cstrUpdate As String = "Xfmr Update"

For Each wb In Workbooks
If LCase(wb.Name) = LCase(cstrWbFacility) Then
Set wbFacility = wb
Exit For
End If
Next wb
If wbFacility Is Nothing Then
If Dir(cstrWbFacility) <> "" Then
Set wbFacility = Workbooks.Open(cstrWbFacility)
Else
MsgBox "Could not find '" & cstrWbFacility & "' in current folder. Please open workbook and start again.", vbInformation, "Ending here"
GoTo end_here
End If
End If
If Evaluate("ISREF('[" & cstrWbFacility & "]" & cstrUpdate & "'!A1)") Then
Set Update = wbFacility.Sheets(cstrUpdate)
Else
MsgBox "Sheet '" & cstrUpdate & "' not found in workbook '" & cstrWbFacility, vbInformation, "Ending here"
GoTo end_here
End If
With Update
For i = 0 To 1
If .Cells(8 + (i * 4), "D").Value <> .Cells(8 + (i * 4), "E").Value Then
.Cells(11 + i, "P").Value = .Cells(8 + (i * 4), "E") - .Cells(8 + (i * 4), "D")
On Error GoTo DoubleRating
End If

If .Cells(10 + (i * 4), "D").Value <> .Cells(10 + (i * 4), "E").Value Then
.Cells(11 + i, "Q").Value = .Cells(10 + (i * 4), "E") - .Cells(10 + (i * 4), "D")
End If

If .Cells(16 + (i * 4), "D").Value <> .Cells(16 + (i * 4), "E").Value Then
.Cells(11 + i, "S").Value = .Cells(16 + (i * 4), "E") - .Cells(16 + (i * 4), "D")
End If
If .Cells(18 + (i * 4), "D").Value <> .Cells(18 + (i * 4), "E").Value Then
.Cells(11 + i, "T").Value = .Cells(18 + (i * 4), "E") - .Cells(18 + (i * 4), "D")
End If
Next i
' End If
End With



end_here:
Set wsUpdate = Nothing
Set wbFacility = Nothing

DoubleRating:
'
MsgBox "Please do these caluclations by hand, they differ from all of the rest and this code will not calculate them for you, sorry"
GoTo EndSub

EndSub:

Call Xfmr_Bold_in_Concatenate1
End Sub
'Sub DoXfmrMath1()
' Dim wsUpdate As Worksheet
' Dim i As Long
' Dim wb As Workbook
' Dim wbFacility As Workbook
' Dim cstrUpdate
' 'Dim wsUpdate As Worksheet
'
' Const cstrPath As String = "C:\Users\nhicks\Documents\Ratings\Saved Versions\"
' Const cstrWbFacility As String = "WAPA-UGPR Facility Rating and SOL Record (Master).xlsm"
' Const cstrwsUpdate As String = "Xfmr Update"
'
' For Each wb In Workbooks
' If LCase(wb.Name) = LCase(cstrWbFacility) Then
' Set wbFacility = wb
' Exit For
' End If
' Next wb
'
' If wbFacility Is Nothing Then
' If Dir(cstrWbFacility) <> "" Then
' Set wbFacility = Workbooks.Open(cstrWbFacility)
' Else
' MsgBox "Could not find '" & cstrWbFacility & "' in current folder. Please open workbook and start again.", vbInformation, "Ending here"
' GoTo end_here
' End If
' End If
'
' If Evaluate("ISREF('[" & cstrWbFacility & "]" & cstrwsUpdate & "'!A1)") Then
' Set wsUpdate = wbFacility.Sheets(cstrwsUpdate)
' Else
' MsgBox "Sheet '" & cstrUpdate & "' not found in workbook '" & cstrWbFacility, vbInformation, "Ending here"
' GoTo end_here
' End If
'
' With wsUpdate
' For i = 0 To 1
' If .Cells(8 + (i * 4), "D").Value <> .Cells(8 + (i * 4), "E").Value Then
' On Error GoTo displaymsg
' .Cells(11 + i, "P").Value = .Cells(8 + (i * 4), "E") - .Cells(8 + (i * 4), "D")
' On Error GoTo 0
' End If
'
' If .Cells(10 + (i * 4), "D").Value <> .Cells(10 + (i * 4), "E").Value Then
' .Cells(11 + i, "Q").Value = .Cells(10 + (i * 4), "E") - .Cells(10 + (i * 4), "D")
' End If
'
' If .Cells(16 + (i * 4), "D").Value <> .Cells(16 + (i * 4), "E").Value Then
' .Cells(11 + i, "S").Value = .Cells(16 + (i * 4), "E") - .Cells(16 + (i * 4), "D")
' End If
'
' If .Cells(18 + (i * 4), "D").Value <> .Cells(18 + (i * 4), "E").Value Then
' .Cells(11 + i, "T").Value = .Cells(18 + (i * 4), "E") - .Cells(18 + (i * 4), "D")
' End If
' Next i
' ' End If
' End With
'
' Call Xfmr_Bold_in_Concatenate1
'
'end_here:
' Set wsUpdate = Nothing
'
'displaymsg:
'MsgBox "Check cells E" & 8 + (i * 4) & " and D" & 8 + (i * 4)

'End Sub
Public Sub Xfmr_Bold_in_Concatenate1()

Dim EN As String, JN As String, GN As String, FN As String, HN As String, KN As String, LN As String, MN As String, NN As String, PN As String, EM As String, FM As String, _
GM As String, HM As String, KM As String

EN = Worksheets("Xfmr Update").Range("N11")
FN = Worksheets("Xfmr Update").Range("P11")
GN = Worksheets("Xfmr Update").Range("O9")
HN = Worksheets("Xfmr Update").Range("R9")
JN = Worksheets("Xfmr Update").Range("Q11")
KN = Worksheets("Xfmr Update").Range("N12")
LN = Worksheets("Xfmr Update").Range("S11")
MN = Worksheets("Xfmr Update").Range("T11")

EM = Worksheets("Xfmr Update").Range("O12")
FM = Worksheets("Xfmr Update").Range("N12")
GM = Worksheets("Xfmr Update").Range("P12")
HM = Worksheets("Xfmr Update").Range("Q12")
KM = Worksheets("Xfmr Update").Range("S12")

Range("C34").Value = ("(" & EN & " : " & " " & GN & " " & JN & " " & LN & " " & "MVA" & "," & " " & HN & " " & FN & " " & MN & " " & "MVA" & ")")
Range("C34").Font.Bold = True
Range("C35").Value = ("(" & FM & " : " & " " & GN & " " & EM & " " & GM & " " & "MVA" & "," & " " & HN & " " & " " & HM & " " & KM & " " & "MVA" & ")")
Range("C35").Font.Bold = True

End Sub
 
Upvote 0

Forum statistics

Threads
1,223,098
Messages
6,170,100
Members
452,301
Latest member
QualityAssurance

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