I have a workbook that comes from someone else so the file path is referring to that person's local drive. So I need to replace the file path with the one in my local drive. I tried 3 methods and they all failed. Please give me some guidelines. Basically, I am trying to find a replace 2 file paths within a formula for an entire sheet (almost all the cells) (see below):
='U:\Futochan\2012\[Futochan2012.xlsm]Counts'!E6+'U:\Futochan\2013\[Futochan2013.xlsm]Counts'!E6
1st Method:
Did this manually. DAta -> Edit Links -> Change sources (Failed, keep prompted me for the links)
2nd Method:
VBA: Did the range.replace. It only replaced the first cell and halted.
3rd Method:
VBA: Did a cell by cell loop :"For each cell in range". I turned off everything. It worked but took 2 hours. :/
Please help!! Thanks!
Firstly, any reason why you can't do a manual find and replace all for "U:\Futochan\2012[Futochan2012.xlsm]"? If it is just two links, and this is a one-off, this is by far the quickest approach.
For Range.replace, what was your range? If you call it on Worksheet.Cells.replace(...) it should replace all instances.
Finally, a quick approach that does not involve Range.Replace is below, but again, reinventing the wheel is a less than preferable approach :)
Private stringsToReplace As New Collection
Sub blah()
Dim ws As Worksheet
Dim arr
Dim formulaCells As Range, area As Range
Dim i As Long, j As Long
stringsToReplace.Add Array("old1", "new1") 'add as many pairs as you like in the format of Array(oldString,newString)
Set ws = ActiveSheet
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error Resume Next
Set formulaCells = ws.Cells.SpecialCells(xlCellTypeFormulas) 'only look at formula cells for speed
On Error GoTo 0
If Not formulaCells Is Nothing Then
For Each area In formulaCells 'we will load into an array in memory, to prevent the horrendously slow enumeration through cells
If area.Count = 1 Then
area.Formula = newFormulaText(area.Formula)
Else
arr = area.Formula
For i = LBound(arr, 1) To UBound(arr, 1)
For j = LBound(arr, 2) To UBound(arr, 2)
arr(i, j) = newFormulaText(arr(i, j))
Next j
Next i
area.Formula = arr
End If
Next area
End If
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Function newFormulaText(ByVal oldText As String) As String
Dim oldNewPair
Dim newText As String
newText = oldText
For Each oldNewPair In stringsToReplace
newText = Replace(newText, oldNewPair(0), oldNewPair(1))
Next oldNewPair
newFormulaText = newText
End Function
Related
Option Explicit
Public Sub consolidateList()
DeleteTableRows (ThisWorkbook.Worksheets("Master").ListObjects("MasterSheet"))
FillTableRows
End Sub
Private Sub FillTableRows()
'set up worksheet objects
Dim wkSheet As Worksheet
Dim wkBook As Workbook
Dim wkBookPath As String
Set wkBook = ThisWorkbook
wkBookPath = wkBook.Path
Set wkSheet = wkBook.Worksheets("Master")
'set up file system objects
Dim oFile As Object
Dim oFSO As Object
Dim oFolder As Object
Dim oFiles As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(wkBookPath)
Set oFiles = oFolder.Files
'set up loop
Dim checkBook As Excel.Workbook
Dim reportDict As Dictionary
Application.ScreenUpdating = False
'initial coordinates
Dim startRow As Long
Dim startColumn As Long
startColumn = 3
Dim i As Long 'tracks within the row of the sheet where information is being pulled from
Dim k As Long 'tracks the row where data is output on
Dim j As Long 'tracks within the row of the sheet where the data is output on
Dim Key As Variant
j = 1
k = wkSheet.Range("a65536").End(xlUp).Row + 1
Dim l As Long
'look t Set checkBook = Workbooks.Open(oFile.Path)hrough folder and then save it to temp memory
On Error GoTo debuger
For Each oFile In oFiles
startRow = 8
'is it not the master sheet? check for duplicate entries
'oFile.name is the name of the file being scanned
'is it an excel file?
If Mid(oFile.Name, Len(oFile.Name) - 3, 4) = ".xls" Or Mid(oFile.Name, Len(oFile.Name) - 3, 4) = ".xlsx" Then
Set checkBook = Workbooks.Open(oFile.Path)
For l = startRow To 600
If Not (IsEmpty(Cells(startRow, startColumn))) Then
'if it is, time do some calculations
Set reportDict = New Dictionary
'add items of the payment
For i = 0 To 33
If Not IsEmpty(Cells(startRow, startColumn + i)) Then
reportDict.Add Cells(4, startColumn + i), Cells(startRow, startColumn + i)
End If
Next i
For i = startRow To 0 Step -1
If Not IsEmpty(Cells(i, startColumn - 1)) Then
reportDict.Add "Consumer Name", Cells(i, startColumn - 1)
Exit For
End If
Next i
'key is added
For Each Key In reportDict
'wkSheet.Cells(k, j) = reportDict.Item(Key)
Dim myInsert As Variant
Set myInsert = reportDict.Item(Key)
MsgBox (myInsert)
wkSheet.ListObjects(1).DataBodyRange(2, 1) = reportDict.Item(Key)
j = j + 1
Next Key
wkSheet.Cells(k, j) = wkSheet.Cells(k, 9) / 4
wkSheet.Cells(k, j + 1) = oFile.Name
'
k = k + 1
' Set reportDict = Nothing
j = 1
Else
l = l + 1
End If
startRow = startRow + 1
Next l
checkBook.Close
End If
' Exit For
Next oFile
Exit Sub
debuger:
MsgBox ("Error on: " & Err.Source & " in file " & oFile.Name & ", error is " & Err.Description)
End Sub
Sub DeleteTableRows(ByRef Table As ListObject)
On Error Resume Next
'~~> Clear Header Row `IF` it exists
Table.DataBodyRange.ClearContents
'~~> Delete all the other rows `IF `they exist
Table.DataBodyRange.Offset(1, 0).Resize(Table.DataBodyRange.Rows.count - 1, _
Table.DataBodyRange.Columns.count).Rows.Delete
On Error GoTo 0
End Sub
Greetings. The above code consolidates a folder of data that's held on excel spreadsheets into one master excel spreadsheet. The goal is to run a macro on Excel Spreadsheet named master on the worksheet named master which opens up other excel workbooks in the folder, takes the information, and puts it into a table in the worksheet "master". After which point, it becomes easy to see the information; so instead of it being held on hundreds of worksheets, the records are held on one worksheet.
The code uses a dictionary (reportDict) to temporarily store the information that is needed from the individual workbooks. The goal then is to take that information and place it in the master table at the bottom row, and then obviously add a new row either after a successful placement or before an attempted placement of data.
The code fails at the following line:
wkSheet.ListObjects(1).DataBodyRange(2, 1) = reportDict.Item(Key)
The failure description is "object or with variable not set" and so the issue is with the reportDict.Item(Key). My guess is that somehow VBA is not recognizing the dictionary item as stable, but I don't know how to correct this. Eventually the goal is to have code which does:
for each key in reportDict
- place the item which is mapped to the key at a unique row,column in the master table
- expand the table to accomodate necessary data
next key
Implicit default member calls are plaguing your code all over.
reportDict.Add Cells(4, startColumn + i), Cells(startRow, startColumn + i)
That's implicitly accessing Range.[_Default] off whatever worksheet is currently the ActiveSheet (did you mean that to be wkSheet.Cells?), to get the Key - since the Key parameter is a String, Range.[_Default] is implicitly coerced into one, and you have a string key. The actual dictionary item at that key though, isn't as lucky.
Here's a MCVE:
Public Sub Test()
Dim d As Dictionary
Set d = New Dictionary
d.Add "A1", Cells(1, 1)
Debug.Print IsObject(d("A1"))
End Sub
This procedure prints True to the debug pane (Ctrl+G): what you're storing in your dictionary isn't a bunch of string values, but a bunch of Range object references.
So when you do this:
Dim myInsert As Variant
Set myInsert = reportDict.Item(Key)
You might as well have declared myInsert As Range, for it is one.
This is where things get interesting:
MsgBox (myInsert)
Nevermind the superfluous parentheses that force-evaluate the object's default member and pass it ByVal to the MsgBox function - here you're implicitly converting Range.[_Default] into a String. That probably works.
So why is this failing then?
wkSheet.ListObjects(1).DataBodyRange(2, 1) = reportDict.Item(Key)
Normally, it wouldn't. VBA would happily do this:
wkSheet.ListObjects(1).DataBodyRange.Cells(2, 1).[_Default] = reportDict.Item(Key).[_Default]
And write the value in the DataBodyRange of the ListObject at the specified location.
I think that's all just red herring. Write explicit code: if you mean to store the Value of a cell, store the Value of a cell. If you mean to assign the Value of a cell, assign the Value of a cell.
I can't replicate error 91 with this setup.
This, however:
DeleteTableRows (ThisWorkbook.Worksheets("Master").ListObjects("MasterSheet"))
...is also force-evaluating a ListObject's default member - so DeleteTableRows isn't receiving a ListObject, it's getting a String that contains the name of the object you've just dereferenced... but DeleteTableRows takes a ListObject parameter, so there's no way that code can even get to run FillTableRows - it has to blow up with a type mismatch before DeleteTableRows even gets to enter. In fact, it's a compile-time error.
So this is a rather long answer that doesn't get to the reason for error 91 on that specific line (I can't reproduce it), but highlights a metric ton of serious problems with your code that very likely are related to this error you're getting. Hope it helps.
You need to iterate through the dictionary's Keys collection.
dim k as variant, myInsert As Variant
for each k in reportDict.keys
debug.print reportDict.Item(k)
next k
I've successfully added shapes into cells (msoShapeOval) in a pivot table. I need to clear and recreate these shapes if the pivot / slicer selection changes. My current method works, but it is slow. Is there any better method to clear shapes in bulk? Note: I do know the exact cell range where all these shapes exist. I've also appied :
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Current code:
Dim Shp as Shape
For Each Shp In rng.Parent.Shapes
If InStrB(Shp.Name, "$") > 0 Then Shp.Delete
Next
It is possible to delete the shapes at once without selecting, with some fine tuning. Let's imagine you want to delete the rectangulars from this:
What you need to do is the following:
loop through all the objects
make an array with all the rectangular's names
delete the objects in the array
Tricky part is the looping through the objects, because you need to increment your array every time, which is not a built-in functionality (like in collection). incrementArray is the function for this.
Furthermore, the first time you increment to the unassigned array, you need to check whether it is allocated (achieved with the IsArrayAllocated function below).
Option Explicit
Sub TestMe()
Dim shp As Shape
Dim arrOfShapes() As Variant 'the () are important!
With ActiveSheet
For Each shp In .Shapes
If InStrB(shp.Name, "Rec") > 0 Then
arrOfShapes = incrementArray(arrOfShapes, shp.Name)
End If
Next
If IsArrayAllocated(arrOfShapes) Then
Debug.Print .Shapes.Range(arrOfShapes(0)).Name
.Shapes.Range(arrOfShapes).Delete
End If
End With
End Sub
The additional functions:
Public Function incrementArray(arrOfShapes As Variant, nameOfShape As String) As Variant
Dim cnt As Long
Dim arrNew As Variant
If IsArrayAllocated(arrOfShapes) Then
ReDim arrNew(UBound(arrOfShapes) + 1)
For cnt = LBound(arrOfShapes) To UBound(arrOfShapes)
arrNew(cnt) = CStr(arrOfShapes(cnt))
Next cnt
arrNew(UBound(arrOfShapes) + 1) = CStr(nameOfShape)
Else
arrNew = Array(nameOfShape)
End If
incrementArray = arrNew
End Function
Function IsArrayAllocated(Arr As Variant) As Boolean
On Error Resume Next
IsArrayAllocated = IsArray(Arr) And _
Not IsError(LBound(Arr, 1)) And _
LBound(Arr, 1) <= UBound(Arr, 1)
End Function
Credits to this guy for the finding that the arrOfShapes should be declared with parenthesis (I have spent about 30 minutes researching why I could not pass it correctly) and to CPearson for the IsArrayAllocated().
To delete all shapes except slicers:
Sub RemoveAllExceptSlicers()
Dim sh As Shape
For Each sh In ActiveSheet.Shapes
If Not sh.Type = MsoShapeType.msoSlicer Then
sh.Delete
End If
Next
End Sub
I have a concatenate based on offset array code that I'm using to combine data.
Public Function concatPlusIfs(rng As Range, sep As String, lgCritOffset1 As Long, lgCritOffset2 As Long, varCrit1 As Variant, lgCritOffset3 As Long, lgCritOffset4 As Long, varCrit2 As Variant, Optional noDup As Boolean = False, Optional skipEmpty As Boolean = False) As String
Dim CL As Range, strTemp As String
If noDup Then 'remove duplicates, use collection to avoid them
Dim newRow As New Collection
On Error Resume Next
For Each CL In rng.Cells
If skipEmpty = False Or Len(Trim(CL.Text)) > 0 Then
If CL.Offset(lgCritOffset1, lgCritOffset2) = varCrit1 And CL.Offset(lgCritOffset3, lgCritOffset4) = varCrit2 Then newRow.Add CL.Text, CL.Text
End If
Next
For i = 0 To newRow.Count
strTemp = strTemp & newRow(i) & sep
Next
Else
For Each CL In rng.Cells
If skipEmpty = False Or Len(Trim(CL.Text)) > 0 Then
If CL.Offset(lgCritOffset1, lgCritOffset2) = varCrit1 And CL.Offset(lgCritOffset3, lgCritOffset4) = varCrit2 Then strTemp = strTemp & CL.Text & sep
End If
Next
End If
concatPlusIfs = Left(strTemp, Len(strTemp) - Len(sep))
End Function
The code works great. It's not mine, but I tweaked someone else's code. The problem is that it will sometimes return a small amount of text and other times a large amount of text. I need the rows to autofit height. Before I started using the new concatPlusIfs formula, I used a code on the worksheet to autofit row height, but it cause a weird problem with the above code and only the above code and I can't find any mention of this type of problem. It works fine with all other arrays or non array formulas that I'm using. Basically what happens is that for a fraction of a second I can see the correct output in the cell and then I get #value!. I have no idea what's going on. I've tried autofit rows as a macro instead and it had the same effect. If I manually autofit the row everything is fine, but that's not a viable option.
Does anyone understand what would cause a problem like this? Or How can I fix it?
I'm not using any merged rows anywhere on the sheet.
Here are a few of the autofit strategies I've tried. One as a macro:
Sub AutoFit()
Worksheets("Sheet1").Range("A2:A" & Rows.Count).Rows.AutoFit
End Sub
Also as a code on the sheet,
Private Sub Worksheet_Change(ByVal Target As Range)
Target.EntireRow.AutoFit
End Sub
And,
Private Sub Worksheet_Calculate()
Application.EnableEvents = False
Me.Rows.AutoFit
'or be specific
Me.Rows("1:33").AutoFit
Application.EnableEvents = True
End Sub
Thank you for any help with this.
You most likely get #VALUE! error when your formula tries to convert the ### from the .Text property to value. That is why you should use .Value2 or .Value instead.
I've incorporated the off-sheet dependents search using the "ShowDependents" and "NavigateArrow" VBA methods. Everything works well but it is just painfully slow (for a large number of dependents).
Are there alternatives, way to speed it up? I've tried disabling the ScreenUpdating but that doesn't speed it up by much.
This is what my code is based on: http://www.technicana.com/vba-for-checking-dependencies-on-another-sheet
Consider the following function which is supposed to return true if the cell you pass it has a direct dependent on a different sheet:
Function LeadsOut(c As Range) As Boolean
Application.ScreenUpdating = False
Dim i As Long, target As Range
Dim ws As Worksheet
Set ws = ActiveSheet
c.ShowDependents
On Error GoTo return_false
i = 1
Do While True
Set target = c.NavigateArrow(False, i)
If c.Parent.Name <> target.Parent.Name Then
ws.Select
ActiveSheet.ClearArrows
Application.ScreenUpdating = True
LeadsOut = True
Exit Function
End If
i = i + 1
Loop
return_false:
LeadsOut = False
ActiveSheet.ClearArrows
Application.ScreenUpdating = True
End Function
Sub test()
MsgBox LeadsOut(Selection)
End Sub
To test it, I linked the test sub to a command button on Sheet1.
In A2 I entered the formula = A1 + 1, with no other formulas on Sheet1.
On Sheet2 I entered the formula =Sheet1!A2.
Back on Sheet1, if I select A2 and invoke the sub it almost instantly pops up "True". But if I select A1 and invoke the sub it returns "False" -- but only after a delay of several seconds.
To debug it, I put a Debug.Print i right before i = i + 1 in the loop. The Immediate Window, after running it again, looks like:
32764
32765
32766
32767
Weird!!!!!
I was utterly stumped until I replaced Debug.Print i by
Debug.Print target.Address(External:=True)
Which led to output that looks ends like:
[dependents.xlsm]Sheet1!$A$1
[dependents.xlsm]Sheet1!$A$1
[dependents.xlsm]Sheet1!$A$1
[dependents.xlsm]Sheet1!$A$1
NavigateArrow(False,i) goes back to the originating cell and stays there once i exceeds the number of dependents! This is seemingly undocumented and massively annoying. The code you linked to was written by someone who hasn't discovered this. As a kludge, you should check that when you are navigating arrows you haven't returned to the starting point. The following seems to work almost instantly in all cases, although I haven't tested it very much:
Function LeadsOut(c As Range) As Boolean
Application.ScreenUpdating = False
Dim i As Long, target As Range
Dim ws As Worksheet
Set ws = ActiveSheet
c.ShowDependents
On Error GoTo return_false
i = 1
Do While True
Set target = c.NavigateArrow(False, i)
If target.Address(External:=True) = c.Address(External:=True) Then
GoTo return_false
End If
If c.Parent.Name <> target.Parent.Name Then
ws.Select
ActiveSheet.ClearArrows
Application.ScreenUpdating = True
LeadsOut = True
Exit Function
End If
i = i + 1
Loop
return_false:
LeadsOut = False
ActiveSheet.ClearArrows
Application.ScreenUpdating = True
End Function
The key lines are the three lines which begin
If target.Address(External:=True) = c.Address(External:=True)
Adding some such check in the sub you linked to should make a massive difference.
I have a spreadsheet that is used for tracking work orders. The first column of the sheet has numbers starting at 14-0001 and continue sequentially all the way down. The numbers were hyperlinked to the .XLS of their respective work order (ex. the cell containing 14-0001 links to Z:\WorkOrders\14-0001-Task Name\14-0001-Task Name.xls)
Problem is, My computer crashed and when Excel recovered the file all the hyperlinks changed from:
**"Z:\blah blah\WorkOrders\14-****-Task Name\14-****-Task Name.xls"**
to
**"C:\Users\blahblah\WorkOrders\14-****-Task Name\14-****-Task Name.xls"**
There are hundreds of entries so I was hoping that I could run a script to fix all of the hyperlinks.
Heres a script I found online which from what I understood is supposed to do what I want, but when I run the script from the VB window in Excel I get "Compile error: Argument not optional" and it highlights Sub CandCHyperlinx()
Code:
Option Explicit
Sub CandCHyperlinx()
Dim cel As Range
Dim rng As Range
Dim adr As String
Dim delstring As String
'string to delete: CHANGE ME! (KEEP quotes!)
delstring = "C:\Users\***\AppData\Roaming\Microsoft\Excel\"
'get all cells as range
Set rng = ActiveSheet.UsedRange
'ignore non hyperlinked cells
On Error Resume Next
'check every cell
For Each cel In rng
'skip blank cells
If cel <> "" Then
'attempt to get hyperlink address
adr = cel.Hyperlinks(1).Address
'not blank? then correct it, is blank get next
If adr <> "" Then
'delete string from address
adr = Application.WorksheetFunction.Substitute(adr, delstring)
'put new address
cel.Hyperlinks(1).Address = adr
'reset for next pass
adr = ""
End If
End If
Next cel
End Sub
Is this even the right script? What am I doing wrong?
Try this:
Sub Macro1()
Const FIND_TXT As String = "C:\" 'etc
Const NEW_TXT As String = "Z:\" 'etc
Dim rng As Range, hl As Hyperlink
For Each rng In ActiveSheet.UsedRange.Cells
If rng.Hyperlinks.Count > 0 Then
Set hl = rng.Hyperlinks(1)
Debug.Print rng.Address(), "Before", hl.TextToDisplay, hl.Address
hl.TextToDisplay = Replace(hl.TextToDisplay, FIND_TXT, NEW_TXT)
hl.Address = Replace(hl.Address, FIND_TXT, NEW_TXT)
Debug.Print rng.Address(), "After", hl.TextToDisplay, hl.Address
End If
Next rng
End Sub
I've just had the same problem, and all the macros I tried didn't work for me. This one is adapted from Tim's above and from this thread Office Techcentre thread. In my case, all my hyperlinks were in column B, between rows 3 and 400 and 'hidden' behind the filename, and I wanted to put the links back to my Dropbox folder where they belong.
Sub FixLinks3()
Dim intStart As Integer
Dim intEnd As Integer
Dim strCol As String
Dim hLink As Hyperlink
intStart = 2
intEnd = 400
strCol = "B"
For i = intStart To intEnd
For Each hLink In ActiveSheet.Hyperlinks
hLink.TextToDisplay = Replace (hLink.TextToDisplay, "AppData/Roaming/Microsoft/Excel",
"Dropbox/References")
hLink.Address = Replace(hLink.Address, "AppData/Roaming/Microsoft/Excel",
"Dropbox/References")
Next hLink
Next i
End Sub
Thanks for your help, Tim!