Hi,
Occasionally 'Named Ranges' misbehave and generate a Run Time Error 1004, probably due to my ignorance of the deep dark secrets of 'Named Ranges'. There are Global 'Named Ranges' associated withe the entire Workbook, and local 'Named Ranges' associated with just one Sheet. I probably defined the 'Named Ranges' that were defined with VBA as Global, when they should have been Local (one Sheet only).
To solve the problem, and alleviate my splitting 'Named Range' headache, I modified the code to not use 'Named Ranges' at all. The 'Named Ranges' you already have will do no harm.
To implement the changes in your file that already contains the code:
a. Make a backup copy of your file.
b. Open my file.
c. Presss ALT F11 to access VBA.
d. Press CTRL R to accces Project Explorer (if is not already visible).
e. Right Click the following modules and Export them (will not affect this file):
(1) ModPrettyPrint
(2) ModToolsAndUtilities
f. Close my file.
g. Open your file.
h. Press ALT F11 to access VBA.
i. Press CTRL R to accces Project Explorer (if is not already visible).
j. Right Click module 'ModPrettyPrint' and select 'Remove ..." to delete the Module.
k. Right Click module 'ModToolsAndUtilities' and select 'Remove ..." to delete the Module.
l. Right Click any module from your file in Project Explorer and import the following modules:
(1) ModPrettyPrint
(2) ModToolsAndUtilities
m. Software Installation completed. Save your file.
Small changes made in Module ModPrettyPrint Sub PaginateQuoteSheet() at approximately line 587:
'Jan 1, 2016 - replaced 'Named Range Array' with Pseudo-Named Range Array
' that uses NO Named Ranges (but simulates Named Ranges)
'Initialize the 'Named Range' Array
'Generate the 'Named Range' Array which contains (separated by commas):
'a. Starting Row Number of the Range
'b. Ending Row Number of the Range
'c. Number of Non-ZERO Height Rows in the Range
'd. Range Name
'Initialize the 'Named Range' Index
ReDim sNamedRangeArray(1 To 1)
Call GeneratePseudoNamedRangeArray(ws, sNamedRangeArray)
iNamedRangeIndex = 0
Changes made in Module ModPrettyPrint (complete rewrite):
Sub GeneratePseudoNamedRangeArray(ws As Worksheet, ByRef sNamedRangeArray() As String)
'This generates a string array of Named Ranges (returned to the calling routine)
'
'The 'Named Range' String Array contains (separated by commas):
'a. Starting Row Number of the Range
'b. Ending Row Number of the Range
'c. Number of Non-ZERO Height Rows in the Range
'd. Range Name
'
'The Array is sorted in Ascending Order
'The only named ranges in the array:
'a. Refer to the input 'Worksheet'
'b. Start with the text 'Range_' (CASE INSENSITIVE)
Dim iColorRGB As Long
Dim iCount As Long
Dim iCountA As Long
Dim iCountB As Long
Dim iLastRowUsed As Long
Dim iNumberOfNonZeroHeightRowsInRange As Long
Dim iRangeEndRow As Long
Dim iRangeStartRow As Long
Dim iRow As Long
Dim iRow2 As Long
Dim xFontSize As Double
Dim sConcatenation As String
Dim sRangeName As String
Dim sValue As String
'Find the Last Row Used
iLastRowUsed = ws.Range("A:C").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'Process each row
For iRow = nBeginROW To iLastRowUsed
If ws.Cells(iRow, "A").MergeCells = True Then
'If the Cell is part of a 'Merged Area' look for
'text greater than one character with RED size 16 Font
'The Text is Part of the Range Name
'This will be the 'Start Row' of the Range
sValue = Trim(ws.Cells(iRow, "A").Value)
xFontSize = ws.Cells(iRow, "A").Font.Size
iColorRGB = ws.Cells(iRow, "A").Font.Color
If Len(sValue) > 1 And xFontSize = 16 And iColorRGB = vbRed Then
iCountA = iCountA + 1
sRangeName = sValue
iRangeStartRow = iRow
'Debug.Print iCountA, iRow, xFontSize, sValue
End If
Else
'If the Cell is NOT part of a 'Merged Area' look for
'the text 'Section Tota' in Column 'C'
'This will be the 'End Row' of the Range
sValue = Trim(ws.Cells(iRow, "C").Value)
xFontSize = ws.Cells(iRow, "A").Font.Size
If UCase(sValue) Like "*SECTION TOTAL*" Or UCase(sValue) Like "*NOT PRICED*" Then
iCountB = iCountB + 1
iRangeEndRow = iRow
'Debug.Print iCountB, iRow, xFontSize, sValue
End If
End If
'Create the 'Named Range' once the 'Start Row' and Matching 'End Row' have been found
If iCountA = iCountB And iRow = iRangeEndRow Then
sRangeName = "Range_" & sRangeName
sRangeName = Replace(sRangeName, "- ", "") 'Remove "- " (DASH followed by SPACE)
sRangeName = Replace(sRangeName, "& ", "") 'Remove "& " (Ampersand followed by SPACE)
sRangeName = Replace(sRangeName, " ", "_") 'Replace SPACE with UNDERSCORE
'Count the number of NON_ZERO height rows in the Pseudo Range
iNumberOfNonZeroHeightRowsInRange = 0
For iRow2 = iRangeStartRow To iRangeEndRow
If ws.Rows(iRow2).Height > 0 Then
iNumberOfNonZeroHeightRowsInRange = iNumberOfNonZeroHeightRowsInRange + 1
End If
Next iRow2
' Debug.Print iCount, sRangeName, iRangeStartRow, iRangeEndRow
'Concatenate the 'Start Row', 'End Row' and Range Name (all separated by commas)
sConcatenation = Format(iRangeStartRow, "00000") & "," & _
Format(iRangeEndRow, "00000") & "," & _
Format(iNumberOfNonZeroHeightRowsInRange, "00000") & "," & _
sRangeName
'Increase the Capacity of the Array by 1
iCount = iCount + 1
ReDim Preserve sNamedRangeArray(1 To iCount)
'Put the Concatenation into the Array
sNamedRangeArray(iCount) = sConcatenation
End If
Next iRow
'Sort the Array in Ascending Order
Call LjmBubbleSortString(sNamedRangeArray)
'Set the CONDITIONAL COMPILATION CONSTANT below to 'True' to output Debug Values to the Immediate Window (CTRL G in debugger)
'Set the CONDITIONAL COMPILATION CONSTANT below to 'False' to NOT output Debug Values to the Immediate Window (CTRL G in debugger)
#Const NEED_NAMED_RANGE_ARRAY_DEBUG_OUTPUT = False
#If NEED_NAMED_RANGE_ARRAY_DEBUG_OUTPUT = True Then
Dim iii As Long
For iii = 1 To iCount
Debug.Print iii, sNamedRangeArray(iii)
Next iii
#End If
End Sub
Changes made in Module ModToolsAndUtilities (complete rewrite):
Sub TraverseNamedRanges()
'This displays the contents of all 'Named Ranges' in the Immediate Window (CTRL G in Debugger)
Dim wb As Workbook
Dim iCount As Long
Dim i As Long
Dim iPos As Long
Dim sNamedRangeAddress As String
Dim sNamedRangeSheetName As String
Dim sNamedRangeSheetAndNameCombination As String
Dim sNamedRangeName As String
'Create the Workbook Object
Set wb = ActiveWorkbook
iCount = wb.Names.Count
For i = 1 To iCount
sNamedRangeSheetAndNameCombination = wb.Names.Item(i).Name
sNamedRangeName = ""
sNamedRangeSheetName = ""
sNamedRangeAddress = ""
'Get the 'Range Name', 'Sheet Name', and 'Address (Refers To)'
'The following algorithm is used because 'RefersToRange.Address' occasionally generates Runtime Error 1004
iPos = InStr(sNamedRangeSheetAndNameCombination, "!")
If iPos = 0 Then
sNamedRangeName = sNamedRangeSheetAndNameCombination
sNamedRangeSheetName = "No Sheet Name Available"
sNamedRangeAddress = Range(sNamedRangeName).Address(False, False)
Else
sNamedRangeName = Right(sNamedRangeSheetAndNameCombination, Len(sNamedRangeSheetAndNameCombination) - iPos)
sNamedRangeSheetName = Left(sNamedRangeSheetAndNameCombination, iPos - 1)
sNamedRangeSheetName = Replace(sNamedRangeSheetName, "'", "")
sNamedRangeAddress = ActiveWorkbook.Sheets(sNamedRangeSheetName).Range(sNamedRangeName).Address(False, False)
End If
Debug.Print i, sNamedRangeAddress, sNamedRangeSheetName, sNamedRangeName
Next i
'Clear object pointers
Set wb = Nothing
End Sub
I apologize for the inconvenience.
Lewis
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks