I have several workbooks that contain 3,500+ named ranges, most of which are not used. To clean up the mess, I would like to run a macro that deletes any unused names.
The following macro seems to work, but it takes about half an hour to run. I actually turned on the status bar so I could be sure it was still progressing.
I would like to get advice on how to accomplish this task more efficiently.
Sub DeleteUnusedNames()
'PURPOSE: Delete named ranges that are not used in formulas in the active workbook
Dim xWB As Workbook: Set xWB = ActiveWorkbook
Dim xWS As Worksheet
Dim xNameCount As Long 'Count of all named ranges
Dim xCount As Long 'Count of current range - used to track progress
Dim xFound As Long 'Count of times a named range was used in a formula - moves on to next code when > 0
Dim xDeletedCount As Long
Dim xName As Name
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
On Error Resume Next
xNameCount = xWB.Names.count
For Each xName In xWB.Names
If xName.Name Like "*Print_*" Then 'Skip Print Areas and Print Titles
Else
xFound = 0
xCount = xCount + 1
Application.StatusBar = "Progress: " & xCount & " of " & xNameCount & " (" & Format(xCount / xNameCount, "0%") & ")"
For Each xWS In xWB.Worksheets
If xWS.Name Like "Workbook Properties" Then 'Don't search the Workbook Properties tab for Names (if this tab exists, it will not have any used names)
Else
xFound = xFound + xWS.UsedRange.Find(What:=xName.Name, _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False).count
If xFound > 0 Then Exit For 'Name was found. Stop looking.
End If
Next xWS
If xFound = 0 Then 'Name was not found in a formula on any of the worksheets
xName.Delete
xDeletedCount = xDeletedCount + 1
End If
End If
Next xName
If xMsg = "" Then
MsgBox "No unused names were found in the workbook", , "No named ranges were deleted"
Else
MsgBox xDeletedCount & " names were deleted", , "Unused named ranges were deleted"
End If
Application.StatusBar = False
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
As commented above, please give this a try.
Is putting all the formulas in arrays rather than named ranges.
Sub DeleteUnusedNames()
'PURPOSE: Delete named ranges that are not used in formulas in the active workbook
Dim xWB As Workbook: Set xWB = ActiveWorkbook
Dim xWS As Worksheet
Dim xNameCount As Long 'Count of all named ranges
Dim xCount As Long 'Count of current range - used to track progress
Dim xFound As Long 'Count of times a named range was used in a formula - moves on to next code when > 0
Dim xDeletedCount As Long
Dim xName As Name
Dim arrData As Variant 'an array to hold all formulas
Dim R As Long, C As Long 'rows/columns
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
On Error Resume Next
xNameCount = xWB.Names.Count
For Each xName In xWB.Names
If xName.Name Like "*Print_*" Then 'Skip Print Areas and Print Titles
Else
xFound = 0
xCount = xCount + 1
Application.StatusBar = "Progress: " & xCount & " of " & xNameCount & " (" & Format(xCount / xNameCount, "0%") & ")"
For Each xWS In xWB.Worksheets
If xWS.Name Like "Workbook Properties" Then 'Don't search the Workbook Properties tab for Names (if this tab exists, it will not have any used names)
Else
arrData = xWS.UsedRange.Formula
For R = LBound(arrData) To UBound(arrData)
For C = LBound(arrData, 2) To UBound(arrData, 2)
If InStr(1, arrData(R, C), xName.Name) > 0 Then
xFound = 1
Exit For
End If
Next C
If xFound > 0 Then Exit For
Next R
End If
Next xWS
If xFound = 0 Then 'Name was not found in a formula on any of the worksheets
xName.Delete
xDeletedCount = xDeletedCount + 1
End If
End If
Next xName
If xMsg = "" Then
MsgBox "No unused names were found in the workbook", , "No named ranges were deleted"
Else
MsgBox xDeletedCount & " names were deleted", , "Unused named ranges were deleted"
End If
Application.StatusBar = False
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
Could replace that loop with the below, should hold all data (... well, hopefully). If all the usedranges load successfully, then it should be a breeze to loop through everything.
Dim Z As Long
Dim arrWholeData() As Variant: ReDim arrWholeData(xWB.Worksheets.Count)
For Z = 1 To xWB.Worksheets.Count
arrWholeData(Z) = xWB.Worksheets(Z).UsedRange.Formula
Next Z
For Each xName In xWB.Names
If xName.Name Like "*Print_*" Then 'Skip Print Areas and Print Titles
Else
xFound = 0
xCount = xCount + 1
Application.StatusBar = "Progress: " & xCount & " of " & xNameCount & " (" & Format(xCount / xNameCount, "0%") & ")"
For Z = 1 To xWB.Worksheets.Count
For R = LBound(arrWholeData(Z)) To UBound(arrWholeData(Z))
For C = LBound(arrWholeData(Z), 2) To UBound(arrWholeData(Z), 2)
If InStr(1, arrWholeData(Z)(R, C), xName.Name) > 0 Then
xFound = 1
Exit For
End If
Next C
If xFound > 0 Then Exit For
Next R
If xFound > 0 Then Exit For
Next Z
If xFound = 0 Then 'Name was not found in a formula on any of the worksheets
xName.Delete
xDeletedCount = xDeletedCount + 1
End If
End If
Next xName
EDIT: added an alternative.
EDIT: FINAL COMPLETE CODE:
Sub DeleteUnusedNames()
'PURPOSE: Delete named ranges that are not used in formulas in the active workbook
Dim startTime As Single, endTime As Single
startTime = Timer
Dim xWB As Workbook: Set xWB = ActiveWorkbook
Dim xNameCount As Long: xNameCount = xWB.Names.count
Dim xCount As Long 'Count of current range - used to track progress
Dim xFound As Long 'Count of times a named range was used in a formula - moves on to next code when > 0
Dim xDeleted As Long 'Count of deleted named ranges
Dim xArrWholeData() As Variant: ReDim xArrWholeData(xWB.Worksheets.count)
Dim xRow As Long 'Row number
Dim xCol As Long 'Column number
Dim xName As Name 'Used for looping through names
Dim xWSNum As Long 'Used for looping through worksheets
Dim xNName As String 'Name of current named range in the loop - used for comparing
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
On Error Resume Next
For xWSNum = 1 To xWB.Worksheets.count
xArrWholeData(xWSNum) = xWB.Worksheets(xWSNum).UsedRange.Formula
Next xWSNum
For Each xName In xWB.Names
xNName = xName.Name
xCount = xCount + 1
If xCount Mod 50 = 0 Then
endTime = Timer
Application.StatusBar = "Progress: " & xCount & " of " & xNameCount & " (" & Format(xCount / xNameCount, "0%") & ") " & (endTime - startTime) & " seconds have passed"
End If
If xNName Like "*Print_*" Then 'Skip Print Areas and Print Titles
Else
xFound = 0
For xWSNum = 1 To xWB.Worksheets.count
If xWB.Worksheets(xWSNum).Name Like "Workbook Properties" Then 'Skip the Workbook Properties worksheet
Else
For xRow = LBound(xArrWholeData(xWSNum)) To UBound(xArrWholeData(xWSNum))
For xCol = LBound(xArrWholeData(xWSNum), 2) To UBound(xArrWholeData(xWSNum), 2)
If InStr(1, xArrWholeData(xWSNum)(xRow, xCol), xNName) > 0 Then
xFound = 1 'Name was found
GoTo NextName 'Stop looking for this name and go to the next name
End If
Next xCol
Next xRow
End If
Next xWSNum
If xFound = 0 Then 'Name was not found in a formula on any of the worksheets
xDeleted = xDeleted + 1
xName.Delete
End If
End If
NextName:
Next xName
endTime = Timer
Application.StatusBar = "Progress: " & xCount & " of " & xNameCount & " (" & Format(xCount / xNameCount, "0%") & ") " & (endTime - startTime) & " seconds have passed"
If xDeleted = 0 Then
MsgBox "No unused names were found in the workbook", , "No named ranges were deleted"
Else
MsgBox xDeleted & " names were deleted:", , "Unused named ranges were deleted" 'Removed & vbCr & xMsg before the first comma
End If
Application.StatusBar = False
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
Another alternative could be to check if the name range has any dependents :
Function HasDependents(r As Range)
r.ShowDependents
HasDependents = r.Address(, , , 1) <> r.NavigateArrow(0, 1).Address(, , , 1)
r.ShowDependents 1
End Function
Sample use :
For Each xName In xWB.Names
If Not HasDependents(xName.RefersToRange) Then xName.Delete
Next
Technically, this does not check if the name is used, but only if the range the name refers to is used (assuming all names refer to range).
To go through the dependents and check if their formulas contain the name, this sample can be modified :
https://excelhelphq.com/how-to-find-all-dependent-cells-outside-of-worksheet-and-workbook-in-excel-vba/
Related
I have between 800 excels files that I need to transfer over to one sheet but before the transfer, I need to add a column ("A:A") and copy one cell value (before column added ("C1") after column ("D1")) and use column ("C:C") to get the range it would need to be pasted in column("A:A")
I have done the code already but struggling to add this on. If anyone can help that would be amazing.
Sub LoopThrough()
Dim MyFile As String, Str As String, MyDir As String
Dim sh As Worksheet, MasterRange As Range, TempWB As Workbook, TempSH As Worksheet, TempRng As Range, TempRow As Range
Dim NewMasterLine As Long
Dim StartTime As Double
Dim MinutesElapsed As String
StartTime = Timer
On Error GoTo ErrorHandler
Set sh = ThisWorkbook.Worksheets("Sheet1")
' Change address to suite
MyDir = "C:\"
MyFile = Dir(MyDir & "*.xls")
ChDir MyDir
' The following lines will put excel in a state similar to "frozen" mode. This will increase the code performance, as CPU will solely focus on performing
' the operations required by the code and not on showing the changes happening on excel
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim x As Long
x = 0
' Here starts the loop related to the files in folder
Do While MyFile <> ""
'TempWB is a Worksheet object - will be the importing worksheet. TempRng is the used range in sheet 1 of the workbook
Set TempWB = Workbooks.Open(FileName:=MyFile, UpdateLinks:=False, Password:=CalcPassword(MyFile))
Columns(1).Insert
Range("c2").Copy Range("A4:A10000")
Set TempSH = TempWB.Worksheets(1)
Set TempRng = TempSH.Range("A1:DB" & TempSH.Range("A" & TempSH.Rows.Count).End(xlUp).Row)
TempRng.Range("A:A").Insert ' This is where I tried to add in the extra column
TempRng.Range("A1").Value = TempRng.Range("D1").Value ' Tried doing this as a test but still pasted as if no changes had been made????
'NewMasterLine is the last used row (+1) of the Master Workbook (It is basically where the new rows will start to be imported)
NewMasterLine = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
If NewMasterLine > 1 Then NewMasterLine = NewMasterLine + 1
'This will loop through all the rows of the range to be imported, checking the first column.
' If the value in the second column is work-xne-ams, will import the single row in the master workbook
For Each TempRow In TempRng.Rows
If Left(TempRow.Cells(1, 2).Value, 5) = "SHIFT" Or TempRow.Row < 4 Then
'If TempRow.Cells(1, 2).Value = "SHIFT--1" Or TempRow.Row < 4 Then
Set MasterRange = sh.Range("A" & NewMasterLine & ":DA" & NewMasterLine)
MasterRange.Value = TempRow.Value
NewMasterLine = NewMasterLine + 1
End If
Next
TempWB.Close savechanges:=False
MyFile = Dir()
x = x + 1
ThisWorkbook.Worksheets("PWD").Range("H2") = x
Loop
ErrorHandler:
If Err.Number <> 0 Then MsgBox "An error occurred." & vbNewLine & vbNewLine & "Last file that was attempted to be opened: " & MyFile & vbNewLine & vbNewLine & Err.Description
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "This code ran successfully in " & MinutesElapsed & " minutes", vbInformation
End Sub
Function CalcPassword(FileName As String) As String
CalcPassword = ""
On Error Resume Next
Dim TheFile As String: TheFile = Split(Split(FileName, "\")(UBound(Split(FileName, "\"))), ".")(0)
Dim PWD As Range: Set PWD = ThisWorkbook.Worksheets("PWD").ListObjects("PWD").DataBodyRange
CalcPassword = WorksheetFunction.VLookup(TheFile, PWD, 5, False)
End Function
I was using the script which I found here : https://excelribbon.tips.net/T008349_Counting_All_Characters.html
It is working as expected however when there are some other objects like pictures, the script returns me the error 438"Object Doesn't Support This Property or Method".
When I deleted the pictures the script was working well again.
Is there an option to put in the script something like "ignore pictures"? Or is there any better type of script to achieve this? I am not good at all at VBA, all help will be much appreciated.
Here's a simplified approach that may work out a bit better. I think being explicit which Shape Types you want to count is going to be a cleaner way of going about this.
Option Explicit
Private Function GetCharacterCount() As Long
Dim wks As Worksheet
Dim rng As Range
Dim cell As Range
Dim shp As Shape
For Each wks In ThisWorkbook.Worksheets
For Each shp In wks.Shapes
'I'd only add the controls I care about here, take a look at the Shape Type options
If shp.Type = msoTextBox Then GetCharacterCount = GetCharacterCount + shp.TextFrame.Characters.Count
Next
On Error Resume Next
Set rng = Union(wks.UsedRange.SpecialCells(xlCellTypeConstants), wks.UsedRange.SpecialCells(xlCellTypeFormulas))
On Error GoTo 0
If not rng Is Nothing Then
For Each cell In rng
GetCharacterCount = GetCharacterCount + Len(cell.Value)
Next
end if
Next
End Function
Sub CountCharacters()
Debug.Print GetCharacterCount()
End Sub
It looks like you can add an if-check like the one here (VBA Code to exclude images png and gif when saving attachments for "PNG" and "GIF".).
You just have to change the if-check to check for the picture type you're using "JPG" or "JPEG"? Simply match the extension to the if-check by replacing "PNG" or "GIF" with your extension in CAPS.
Add the if-check right above where the error is occurring or better yet, add it above the scope of where the error is occurring.
I took the script from your link and modified it. Now it works.
It's far from perfect (there're some cases where it can still crash), but now it supports handling Shapes with no .TextFrame property:
Sub CountCharacters()
Dim wks As Worksheet
Dim rng As Range
Dim rCell As Range
Dim shp As Shape
Dim bPossibleError As Boolean
Dim bSkipMe As Boolean
Dim lTotal As Long
Dim lTotal2 As Long
Dim lConstants As Long
Dim lFormulas As Long
Dim lFormulaValues As Long
Dim lTxtBox As Long
Dim sMsg As String
On Error GoTo ErrHandler
Application.ScreenUpdating = False
lTotal = 0
lTotal2 = 0
lConstants = 0
lFormulas = 0
lFormulaValues = 0
lTxtBox = 0
bPossibleError = False
bSkipMe = False
sMsg = ""
For Each wks In ActiveWorkbook.Worksheets
' Count characters in text boxes
For Each shp In wks.Shapes
If TypeName(shp) <> "GroupObject" Then
On Error GoTo nextShape
lTxtBox = lTxtBox + shp.TextFrame.Characters.Count
End If
nextShape:
Next shp
On Error GoTo ErrHandler
' Count characters in cells containing constants
bPossibleError = True
Set rng = wks.UsedRange.SpecialCells(xlCellTypeConstants)
If bSkipMe Then
bSkipMe = False
Else
For Each rCell In rng
lConstants = lConstants + Len(rCell.Value)
Next rCell
End If
' Count characters in cells containing formulas
bPossibleError = True
Set rng = wks.UsedRange.SpecialCells(xlCellTypeFormulas)
If bSkipMe Then
bSkipMe = False
Else
For Each rCell In rng
lFormulaValues = lFormulaValues + Len(rCell.Value)
lFormulas = lFormulas + Len(rCell.Formula)
Next rCell
End If
Next wks
sMsg = Format(lTxtBox, "#,##0") & _
" Characters in text boxes" & vbCrLf
sMsg = sMsg & Format(lConstants, "#,##0") & _
" Characters in constants" & vbCrLf & vbCrLf
lTotal = lTxtBox + lConstants
sMsg = sMsg & Format(lTotal, "#,##0") & _
" Total characters (as constants)" & vbCrLf & vbCrLf
sMsg = sMsg & Format(lFormulaValues, "#,##0") & _
" Characters in formulas (as values)" & vbCrLf
sMsg = sMsg & Format(lFormulas, "#,##0") & _
" Characters in formulas (as formulas)" & vbCrLf & vbCrLf
lTotal2 = lTotal + lFormulas
lTotal = lTotal + lFormulaValues
sMsg = sMsg & Format(lTotal, "#,##0") & _
" Total characters (with formulas as values)" & vbCrLf
sMsg = sMsg & Format(lTotal2, "#,##0") & _
" Total characters (with formulas as formulas)"
MsgBox Prompt:=sMsg, Title:="Character count"
ExitHandler:
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
If bPossibleError And Err.Number = 1004 Then
bPossibleError = False
bSkipMe = True
Resume Next
Else
MsgBox Err.Number & ": " & Err.Description
Resume ExitHandler
End If
End Sub
You could try:
Option Explicit
Sub test()
Dim NoOfChar As Long
Dim rng As Range, cell As Range
NoOfChar = 0
For Each cell In ThisWorkbook.Worksheets("Sheet1").UsedRange '<- Loop all cell in sheet1 used range
NoOfChar = NoOfChar + Len(cell.Value) '<- Add cell len to NoOfChar
Next cell
Debug.Print NoOfChar
End Sub
Please bear with me. My code is probably complete shit, so I appreciate all feedback! So what this does is, on my main workbook, there are a bunch of UNC hyperlinks in Row M, that link to files in a section drive.
What this code does:
Go down the list of hyperlinks in Column M, opens them up and executes the code inside of the "With WBSsource".
First, it searches for instances of the incorrect filepath (st) inside each of the cells formulas (NOT VALUES), and increments a counter using InStr (t), then after the worksheet has been searched, if the final count (c) is more than 0, meaning the search found at least one incorrect filepath, it will proceed to the next step.
It does a Cells.Replace on a worksheet (ws.) basis (at the FORMULA level)
Cells per worksheet are all done, it should save the workbook and close it before moving onto the next one.
Any links that could not be opened will appear in a final popup.
It is by Step 3 that it starts to run sluggish and crash.
I'm trying my best to get this automated and saving the workbooks. Then, once they're all updated, running this code again would be much faster cause it won't have to replace everything again.
Sub List_UpdateAndSave()
Dim lr As Long
Dim i As Integer
Dim WBSsource As Workbook
Dim FileNames As Variant
Dim msg As String
Dim ws As Worksheet
Dim r As Range, t As Long, c As Integer
' Update the individual credit models
With ThisWorkbook.ActiveSheet
lr = .Cells(.Rows.Count, "M").End(xlUp).Row
FileNames = .Range("M2:M" & lr).Value
End With
For i = LBound(FileNames, 1) To UBound(FileNames, 1)
On Error Resume Next
If FileNames(i, 1) Like "*.xls*" Then
Set WBSsource = Workbooks.Open(FileNames(i, 1), _
ReadOnly:=False, _
Password:="", _
UpdateLinks:=3)
If Err = 0 Then
With WBSsource
Application.DisplayAlerts = False
ActiveWorkbook.Final = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
st = "\\corp\Accounts\" 'Search Phrase
n = "\\corp\StackOverflow\Accounts\" 'New Phrase
c = 0
For Each ws In WBSsource.Worksheets
ws.Activate
t = 0
On Error Resume Next
For Each r In ws.Cells.SpecialCells(xlCellTypeFormulas)
t = InStr(1, r.Formula, st)
If t > 0 Then
c = c + 1
End If
Next r
Next ws
If c > 0 Then
'MsgBox ws.Name & Chr(10) & (c)
ws.Cells.Replace st, n
End If
.UpdateLink Name:=ActiveWorkbook.LinkSources, Type:=xlExcelLinks
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
.Save
.Close True
End With
Else
msg = msg & FileNames(i, 1) & Chr(10) & Chr(10)
On Error GoTo 0
End If
End If
Set WBSsource = Nothing
Next i
If Len(msg) > 0 Then
'MsgBox "The Following Files Could Not Be Opened" & _
' Chr(10) & msg, 48, "Error"
Set objShell = CreateObject("Wscript.Shell")
objShell.Popup "The Following Files Could Not Be Opened" & _
Chr(10) & Chr(10) & msg, 48, "Error"
End If
Application.DisplayAlerts = True
End Sub
It's not completely crap. I just learned that we could create an array with this.
FileNames = .Range("M2:M" & lr).Value
It may crash since there's no range limit on the 3rd step. Try getting the last row and column on each worksheet, then create a range based on that.
With ws
' Get end cells
With .Cells.SpecialCells(xlCellTypeLastCell)
intLastRow = .Row
intLastCol = .Column
End With
For each r in .Range(.Cells(1,1), .Cells(intLastRow, intLastCol))
' Check formula if it contains specific string
t = InStr(1, r.Formula, st)
If t > 0 Then
c = c + 1
End If
' Replace formula with new string
r.Formula = Replace(r.Formula, st, n)
Next r
End With
Edit: Here's the full code. Let me know if this works for you.
Option Explicit
' Update the individual credit models
Sub List_UpdateAndSave()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo ErrorHandler
' Declaration
Dim i As Long
Dim arrLinks As Variant
Dim strLinksErr As String
' Initialization
Dim strPathCur As String: strPathCur = "\\corp\Accounts\" ' search phrase
Dim strPathNew As String: strPathNew = "\\corp\StackOverflow\Accounts\" ' new phrase
With ThisWorkbook.ActiveSheet
' Get links from sheet
arrLinks = .Range("M2:M" & .Cells.SpecialCells(xlCellTypeLastCell).Row).Value
End With
For i = LBound(arrLinks, 1) To UBound(arrLinks, 1)
' Check for Excel links
If VBA.InStr(1, arrLinks(i, 1), ".xls", vbTextCompare) > 0 Then
FnExcelUpdateLinks arrLinks(i, 1), strPathCur, strPathNew
Else
' Add to list of links that could not be opened
strLinksErr = strLinksErr & arrLinks(i, 1) & Chr(10)
End If
Next i
ErrorHandler:
' Display any errors
If Err.Number <> 0 Then MsgBox Err.Description, vbCritical, "Error " & Err.Number
' Display any non-Excel links
If strLinksErr <> "" Then
MsgBox "The following files could not be opened:" & _
Chr(10) & strLinksErr, 48, "Error"
End If
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Function FnExcelUpdateLinks(ByVal strWbkPath As String, ByRef strPathCur As String, ByRef strPathNew As String)
Dim intLastRow As Long, intLastCol As Long
Dim wbkTmp As Workbook
Dim shtTmp As Worksheet
Dim rngCell As Range
' Open link as workbook
Set wbkTmp = Workbooks.Open(strWbkPath, ReadOnly:=False, Password:="", UpdateLinks:=3)
With wbkTmp
For Each shtTmp In .Worksheets
With shtTmp
' Get end cells
With .Cells.SpecialCells(xlCellTypeLastCell)
intLastRow = .Row
intLastCol = .Column
End With
For Each rngCell In .Range(.Cells(1, 1), .Cells(intLastRow, intLastCol))
If VBA.InStr(1, rngCell.Formula, strPathCur) > 0 Then
rngCell.Formula = Replace(rngCell.Formula, strPathCur, strPathNew)
End If
Next rngCell
End With
Next shtTmp
.UpdateLink Name:=.LinkSources, Type:=xlExcelLinks
.Save
.Close True
End With
End Function
The following code opens selected files, one at a time; if a file contains specific text string in B11 (there are four variation: LS2A, LS1PRA, LS1A and LSM12), specified data from Sheet(1) of each file is copied into an array. The search is performed by function “SearchFor” that is called in the main routine.
The array ArrCopy is filled with data from each file and should output into one of the four sheets in Master Workbook(SABI, SABII,LSM or LPRI&II). The output sheet is determined by the text string in B11 of each file.
I can’t get data to output to Master workbook for some reason. I've tried Debug.Print each array item after it's filled and I can see that the array is filled with correct data but I can't get the values to tranfer to the master workbook. The code runs but nothing is outputed on the worksheet.
Please suggest how to make this work. Thanks
Option Explicit
Function SearchFor(output As Worksheet)
Dim rowsCount As Long
Dim NCBead1 As Long, NCBead2 As Long, PCBead1 As Long, PCBead2 As Long
Dim IniString As String, IniVar As String
Dim rngCell As Range, rngCell2 As Range
Dim ArrCopy(1 To 9) As Variant
Dim LastRow As Long
Dim aCell As Range
LastRow = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
'extract initial after last underscore
IniString = ActiveWorkbook.Sheets(1).Range("B6").Value
IniVar = Right(IniString, Len(IniString) - InStrRev(IniString, "_", , 1))
Debug.Print IniVar
'Debug.Print "LastRow = " & LastRow
Set aCell = ActiveSheet.Range("B1:B" & LastRow).Find(What:="Trimmed Mean", LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'Debug.Print "Trimmed Mean can be found in Row # " & aCell.Row
'wb.Sheets(1).Select
For Each rngCell In ActiveSheet.Range("B" & aCell.Row & ":B" & LastRow)
If InStr(rngCell, "NC") > 0 Then
Debug.Print rngCell.Row
NCBead1 = rngCell.Offset(0, 1).Value
NCBead2 = rngCell.Offset(0, 2).Value
'End If
Exit For
End If
Next rngCell
For Each rngCell2 In ActiveSheet.Range("B" & aCell.Row & ":B" & LastRow)
If InStr(rngCell2, "PC") > 0 Then
Debug.Print rngCell2.Row
PCBead1 = rngCell2.Offset(0, 1).Value
PCBead2 = rngCell2.Offset(0, 2).Value
'End If
Exit For
End If
Next rngCell2
'Next searched
Debug.Print NCBead2
ArrCopy(1) = ActiveSheet.Range("B3").Value
ArrCopy(2) = IniVar
ArrCopy(3) = NCBead1
ArrCopy(4) = NCBead2
ArrCopy(5) = PCBead1
ArrCopy(6) = PCBead2
ArrCopy(7) = ActiveSheet.Range("B6").Value
ArrCopy(8) = NCBead1
ArrCopy(9) = NCBead1
' one row spanning several columns
Debug.Print "ArrCopy" & ArrCopy(1)
Debug.Print "ArrCopy" & ArrCopy(2)
Debug.Print "ArrCopy" & ArrCopy(3)
Dim Destination As Range
Set Destination = output.Range("A" & output.Range("A" & Rows.Count).End(xlUp).Row + 1)
Set Destination = Destination.Resize(1, UBound(ArrCopy))
Destination.Value = ArrCopy
End Function
Sub openselectedfiles()
Dim SaveDriveDir As String, MyPath As String, FnameInLoop As String
Dim mybook As Workbook, thisWb As Workbook
Dim N As Long, LstUnderSc As Long, ExtPer As Long, Varin As Long
Dim Fname As Variant, ArrCopy(1 To 9) As Variant
Dim output As Worksheet
Dim inLS2A As Boolean, inLS1PRA As Boolean, inLS1A As Boolean, inLSM12 As Boolean
Set thisWb = ThisWorkbook
' Save the current directory.
SaveDriveDir = CurDir
' Set the path to the folder that you want to open.
MyPath = Application.DefaultFilePath
' Change drive/directory to MyPath.
ChDrive MyPath
ChDir MyPath
' Open GetOpenFilename with the file filters.
Fname = Application.GetOpenFilename( _
FileFilter:="CSV Files (*.csv),*.csv", _
Title:="Select a file or files", _
MultiSelect:=True)
' Perform some action with the files you selected.
If IsArray(Fname) Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For N = LBound(Fname) To UBound(Fname)
' Get only the file name and test to see if it is open.
FnameInLoop = Right(Fname(N), Len(Fname(N)) - InStrRev(Fname(N), Application.PathSeparator, , 1))
If bIsBookOpen(FnameInLoop) = False Then
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(Fname(N))
On Error GoTo 0
If Not mybook Is Nothing Then
mybook.Sheets(1).Select
With ActiveSheet.Range("B11")
inLS2A = InStr(1, .Value, "LS2A", 1) > 0
inLS1PRA = InStr(1, .Value, "LS1PRA", 1) > 0
inLS1A = InStr(1, .Value, "LS1A", 1) > 0
inLSM12 = InStr(1, .Value, "LSM12", 1) > 0
End With
If inLS2A Then
Set output = thisWb.Sheets("SABII")
SearchFor output
ElseIf inLS1PRA Then
Set output = thisWb.Sheets("LPRI&II")
SearchFor output
ElseIf inLS1A Then
Set output = thisWb.Sheets("sabI")
SearchFor output
ElseIf inLSM12 Then
Set output = thisWb.Sheets("LSM")
SearchFor output
End If
'End If
mybook.Close SaveChanges:=False
Set mybook = Nothing
End If
Else
MsgBox "We skipped this file : " & Fname(N) & " because it is already open."
End If
Next N
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
' Change drive/directory back to SaveDriveDir.
ChDrive SaveDriveDir
ChDir SaveDriveDir
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Contributed by Rob Bovey
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
We have a excel file with a bunch of sheets. The first sheet is a "Search page" thing... where we want to type the name of the spreadsheet (for example in cell A1) we are looking for and then that would automatically pop up the right spreadsheet (within the same file).
I tried that, it didn't work at all :
Function ActivateWB(wbname As String)
'Open wbname.
Workbooks(wbname).Activate
End Function
Two code sets below
Add a full hyperlinked Table of Contents page
For your specific question re finding a sheet that is referred to by A1 on the first sheet see 'JumpSheet' code (at bottom)
Create TOC
Option Explicit
Sub CreateTOC()
Dim ws As Worksheet
Dim nmToc As Name
Dim rng1 As Range
Dim lngProceed As Boolean
Dim bNonWkSht As Boolean
Dim lngSht As Long
Dim lngShtNum As Long
Dim strWScode As String
Dim vbCodeMod
'Test for an ActiveWorkbook to summarise
If ActiveWorkbook Is Nothing Then
MsgBox "You must have a workbook open first!", vbInformation, "No Open Book"
Exit Sub
End If
'Turn off updates, alerts and events
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
'If the Table of Contents exists (using a marker range name "TOC_Index") prompt the user whether to proceed
On Error Resume Next
Set nmToc = ActiveWorkbook.Names("TOC_Index")
If Not nmToc Is Nothing Then
lngProceed = MsgBox("Index exists!" & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbCritical, "Warning")
If lngProceed = vbYes Then
Exit Sub
Else
ActiveWorkbook.Sheets(Range("TOC_Index").Parent.Name).Delete
End If
End If
Set ws = ActiveWorkbook.Sheets.Add
ws.Move before:=Sheets(1)
'Add the marker range name
ActiveWorkbook.Names.Add "TOC_INDEX", ws.[a1]
ws.Name = "TOC_Index"
On Error GoTo 0
On Error GoTo ErrHandler
For lngSht = 2 To ActiveWorkbook.Sheets.Count
'set to start at A6 of TOC sheet
'Test sheets to determine whether they are normal worksheets
ws.Cells(lngSht + 4, 2).Value = TypeName(ActiveWorkbook.Sheets(lngSht))
If TypeName(ActiveWorkbook.Sheets(lngSht)) = "Worksheet" Then
'Add hyperlinks to normal worksheets
ws.Hyperlinks.Add Anchor:=ws.Cells(lngSht + 4, 1), Address:="", SubAddress:="'" & ActiveWorkbook.Sheets(lngSht).Name & "'!A1", TextToDisplay:=ActiveWorkbook.Sheets(lngSht).Name
Else
'Add name of any non-worksheets
ws.Cells(lngSht + 4, 1).Value = ActiveWorkbook.Sheets(lngSht).Name
'Colour these sheets yellow
ws.Cells(lngSht + 4, 1).Interior.Color = vbYellow
ws.Cells(lngSht + 4, 2).Font.Italic = True
bNonWkSht = True
End If
Next lngSht
'Add headers and formatting
With ws
With .[a1:a4]
.Value = Application.Transpose(Array(ActiveWorkbook.Name, "", Format(Now(), "dd-mmm-yy hh:mm"), ActiveWorkbook.Sheets.Count - 1 & " sheets"))
.Font.Size = 14
.Cells(1).Font.Bold = True
End With
With .[a6].Resize(lngSht - 1, 1)
.Font.Bold = True
.Font.ColorIndex = 41
.Resize(1, 2).EntireColumn.HorizontalAlignment = xlLeft
.Columns("A:B").EntireColumn.AutoFit
End With
End With
'Add warnings and macro code if there are non WorkSheet types present
If bNonWkSht Then
With ws.[A5]
.Value = "This workbook contains at least one Chart or Dialog Sheet. These sheets will only be activated if macros are enabled (NB: Please doubleclick yellow sheet names to select them)"
.Font.ColorIndex = 3
.Font.Italic = True
End With
strWScode = "Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)" & vbCrLf _
& " Dim rng1 As Range" & vbCrLf _
& " Set rng1 = Intersect(Target, Range([a6], Cells(Rows.Count, 1).End(xlUp)))" & vbCrLf _
& " If rng1 Is Nothing Then Exit Sub" & vbCrLf _
& " On Error Resume Next" & vbCrLf _
& " If Target.Cells(1).Offset(0, 1) <> ""Worksheet"" Then Sheets(Target.Value).Activate" & vbCrLf _
& " If Err.Number <> 0 Then MsgBox ""Could not select sheet"" & Target.Value" & vbCrLf _
& "End Sub" & vbCrLf
Set vbCodeMod = ActiveWorkbook.VBProject.VBComponents(ws.CodeName)
vbCodeMod.CodeModule.AddFromString strWScode
End If
'tidy up Application settins
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
ErrHandler:
If Err.Number <> 0 Then MsgBox Err.Description & vbCrLf & "Please note that your Application settings have been reset", vbCritical, "Code Error!"
End Sub
Jump Sheet
Sub JumpSheet()
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets(Sheets(1).[a1].Value)
On Error GoTo 0
If Not ws Is Nothing Then
Application.Goto ws.[a1]
Else
MsgBox "Sheet not found", vbCritical
End If
End Sub
Iterate over all sheets of the current workbook and activate the one with the right name. Here is some code which should give you the idea, You can put this in the code section of your search sheet and associate it with the "Clicked" event of a button.
Option Explicit
Sub Search_Click()
Dim sheetName As String, i As Long
sheetName = Range("A1")
For i = 1 To ThisWorkbook.Sheets.Count
If ThisWorkbook.Sheets(i).Name = sheetName Then
ThisWorkbook.Sheets(i).Activate
Exit For
End If
Next
End Sub
I am just confused about the question. Are you trying to open Workbook or Worksheet?.
If you trying to navigate to worksheet with in workbook,
E.g.
Worksheets("Sheet2").Activate