Changing reference between sheet cells in different excel file

[jirka_x]

Hi,
I have a serious problem. When I want to change reference between cells in two excel files. I set cell formula reference to a non existing name of sheet (='c:\apps\[Sesit11.xls]l5'!$A$1) (sheet l5 doesn't exist in file sesit11.xls). After change confirmation of cell formula, "Select sheet" dialog box opens (printscreen of dialog box on image).

My questions are:
Is it possible to disable cell refreshing after changes and keep cell changes without opening "select sheet" dialog box?
Is it possible to catch event, that opens "select sheet" dialog box?
Is it possible to click on "Cancel" button in opened dialog box?

Thank you for your ideas or solutions, that can help to solve my problem.

Regards Jiri Spacek

[david000]

You could edit the formula via a macro, then WAIT for the sheet to exist otherwise you'll get an even worse error with this method




[vba]
Sub foo()

ActiveCell.Formula = "='c:\apps\[Sesit11.xls]l5'!$A$1" 'don't use this until this path exists!

End Sub
[/vba]


OK, now there are many many ways to work with links and paths; from the simple to the near impossible.

It looks like you can take advantage of this event:
[VBA]
Private Sub Workbook_NewSheet(ByVal Sh As Object)
'code here!
End Sub
[/VBA]

And perhaps then you can do some checks for correct path and so on.

[jirka_x]

I have rutine, which changing refence between more then 10,000 xls files and I need to do it atomaticly without some manual click.

Files which I changing are not mine, so i can create new sheets in them.
So, one of the solutions is to check, if sheet in reference exist and if not then insert into cell changed reference without first "=" ("'c:\apps\[Sesit11.xls]l5'!$A$1)") only like a string and then each owner of file, change that strings back to formula.
But if i must search every sheet obtain in reference by opening file, it takes a lot of time.
If i can catch en event when dialog box "Select sheet" open and after that i make a change on reference, i save o lot of time.

Do you know how to catch some event before dialog box open or how to solve this problem other way?

Thank you for answer.

Jirka_x

[david000]

I'm still a little confused

Why not just use a template that has this sheet name in it already or write a procedure to force the sheet name to be the name your looking for?


[vba]


Public Function FILEEXISTS(file As String) As Boolean
' Returns True if a specified file exists
On Error GoTo ErrorHandler
If file = "" Then
FILEEXISTS = False
Exit Function
End If
If Dir(file) = "" Then FILEEXISTS = False Else FILEEXISTS = True
Exit Function
ErrorHandler:
FILEEXISTS = False
End Function


Public Sub TestForSheet()
Dim FileName As String
Dim FullPath As String
Dim wks As Worksheet
Dim wk As Workbook

FileName = "yikes" & ".xlsm" 'your file name
FullPath = ThisWorkbook.Path & "\" & FileName 'your path and file name

If FILEEXISTS(FullPath) Then
If MsgBox("File exits, check for sheet?", vbYesNo) <> vbYes Then
Exit Sub
Else

Set wk = Workbooks.Open(FileName:=FullPath) 'open book if exists

For Each wks In wk.Worksheets 'look for sheet

If wks.Name = "Sheet3" Then 'do something
MsgBox "Found" 'do something
End If


Next wks

End If
End If
End Sub



[/vba]

[mdmackillop]

Why not create an index of all the sheets in all the workbooks. This could be quickly searched for a valid name. If found, create the formula, if not, add the sheet to the workbook and the index.

[jirka_x]

This is my solution of problem with replacing reference in many MS Excel files.
If someone have some idea how to optimise this code, please write me.
Thank you.

[VBA]
Const ForWriting = 2
Const ForAppend = 8

Public filesXLS(100000) As String
Public fCountXLS As Long

Public zrusOperaci As Boolean
Public showAppW As Boolean
Public Const SheetCount = 20

Public Function AkceXLS(file As String, CestaA As String, CestaB As String) As String
Dim xlApp As Excel.Application
Dim aSheet As Excel.Worksheet
Dim curDoc As Excel.Workbook
Dim stav
Dim found
Dim hyp As Excel.Hyperlink
Dim n, dat, i, j, k, l
Dim datum As Date
Dim lf
Dim logF As String
Dim Lists() As String
Dim Sh As Excel.Sheets
Dim frm As String
Dim path As String
Dim list As String

found = 0

DoEvents
On Error GoTo CantOpenFile

Set xlApp = New Excel.Application

xlApp.Visible = showAppW
xlApp.DisplayAlerts = False
xlApp.ScreenUpdating = showAppW
xlApp.AskToUpdateLinks = False
xlApp.IgnoreRemoteRequests = True


'datum = Now()
'lf = LogF & "\log" & CStr(Year(datum)) & CStr(Month(datum)) & CStr(Day(datum)) & ".LOG"

logF = GetPath("log")
If Right(logF, 1) = "\" Then
lf = logF & "log.LOG"
Else
lf = logF & "\log.LOG"
End If

ReDim Lists(fCountXLS, SheetCount) As String

Forms("Frm_upravacest").StavAplikace.Caption = "Na??t?n? list? v XLS souborech"
Forms("Frm_upravacest").Repaint

'Save to array names of sheets
For i = 0 To fCountXLS - 1
Set curDoc = xlApp.Workbooks.Open(FileName:=filesXLS(i), UpdateLinks:=xlUpdateLinksNever)
Set Sh = curDoc.Sheets
'Display every worksheet and chart
Lists(i, 0) = filesXLS(i)
For j = 1 To Sh.Count
Lists(i, j) = Sh(j).name
Next j
curDoc.Close SaveChanges:=wdDoNotSaveChanges
Next i

Set n = CreateObject("Scripting.FileSystemObject")
Set dat = n.OpenTextFile(lf, ForAppend, True)
For i = 0 To fCountXLS - 1

Forms("Frm_upravacest").StavAplikace.Caption = "Soubor: " & filesXLS(i)
Forms("Frm_upravacest").pocet.Caption = "Soubor: " & "(" & i + 1 & " z " & fCount & ")"
Forms("Frm_upravacest").Repaint

Set curDoc = xlApp.Workbooks.Open(FileName:=filesXLS(i), UpdateLinks:=xlUpdateLinksNever)


curDoc.Saved = True

On Error GoTo 0
On Error GoTo CantChangeTracking
On Error GoTo 0


For Each aSheet In curDoc.Worksheets

'replace hyperlinks in xls file
If aSheet.Hyperlinks.Count > 0 Then
For Each hyp In aSheet.Hyperlinks
On Error Resume Next
hyp.Address = replace(hyp.Address, CestaA, CestaB)
On Error Resume Next
Next hyp
End If

On Error Resume Next
'If (aSheet.Cells.replace(What:=CestaA, Replacement:=CestaB, LookAt:=xlPart, _
' SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False) = True) Then
' found = found + 1
'End If

Dim c

'search value to replace in cells on select sheet
Set c = Cells.Find(What:=CestaA, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not c Is Nothing Then

Dim firstAddress

firstAddress = c.Address
Do
'parse formulala
frm = c.Formula
If Left(frm, 1) = "=" Then
k = InStr(frm, "'")
i = InStr(frm, "]")
j = InStr(i, frm, "'")
path = replace(Mid(frm, k + 1, i - k - 1), "[", "")
list = Mid(frm, i + 1, j - i - 1)
'check if file exist
If Dir(path) <> "" Then
'check if sheet exist
If hledejList(Lists(), list, path) Then
c.replace What:=CestaA, Replacement:=CestaB, LookAt:= _
xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Else
'if sheet doesn't exist the program seve to cell reference without first "=" as a string value
c.Formula = Mid(frm, 2, Len(frm) - 1)
c.replace What:=CestaA, Replacement:=CestaB, LookAt:= _
xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End If
End If
Else
'c.replace What:=CestaA, Replacement:=CestaB, LookAt:= _
xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End If
Set c = Cells.FindNext(c)
found = found + 1
Loop While Not c Is Nothing And c.Address <> firstAddress
End If

On Error Resume Next
Next aSheet

Dim alinks

'replace linksources
Dim lStr, nStr
alinks = xlApp.ActiveWorkbook.LinkSources(xlExcelLinks)
If Not IsEmpty(alinks) Then
For j = 1 To UBound(alinks)
lStr = alinks(j)
If InStr(lStr, CestaA) > 0 Then
nStr = CestaB & "\" & Right(lStr, Len(lStr) - Len(CestaA))
nStr = replace(nStr, "\\", "\")

On Error Resume Next

xlApp.ActiveWorkbook.ChangeLink name:=lStr, NewName:=nStr, Type:=xlExcelLinks
End If
Next j
End If


If Not curDoc.Saved Then
On Error GoTo CantSaveFile
curDoc.Save
stav = ";ANO;Zmenen"
Else
stav = ";ANO;Nezmenen"
End If


pokracuj:
datum = Now()
lf = "[" & Day(datum) & ":" & Month(datum) & ":" & Year(datum) & " " & Hour(datum) & "." & Minute(datum) & "." & Second(datum) & "] "
dat.writeline (CStr(lf & filesXLS(i) & stav))
curDoc.Close SaveChanges:=wdDoNotSaveChanges
Set curDoc = Nothing
On Error GoTo 0
If zrusOperaci Then
GoTo AllDone
End If
Next i

AllDone:
xlApp.Quit
Set xlApp = Nothing
AkceXLS = stav
dat.Close
Exit Function

'error states
CantChangeTracking:
stav = ";ANO;NelzeZmenit"
Resume pokracuj
CantSaveFile:
stav = ";ANO;NelzeUlozit"
Resume pokracuj
CantOpenFile:
stav = ";NE;NelzeOtevrit"
Resume pokracuj
DocumentProtected:
stav = ";ANO;Protected"
Resume pokracuj

End Function

Function hledejList(pole() As String, list As String, path As String) As Boolean
Dim i, j
Dim pathIDX As Long
Dim pathFounf As Boolean

pathFound = False
hledejList = False

i = UBound(pole)
pathIDX = 0

j = 0
While j < i And Not pathFound
If StrComp(pole(j, 0), path, 1) = 0 Then
pathIDX = j
pathFound = True
End If
j = j + 1
Wend

If Not pathFound Then
Exit Function
End If

j = 1
While j < SheetCount And Not hledejList And pole(pathIDX, j) <> ""
If StrComp(pole(pathIDX, j), list, 1) = 0 Then
hledejList = True
End If
j = j + 1
Wend

'For j = 1 To SheetCount
' If pole(pathIDX, j) = "" Then
' Exit Function
' End If
' If pole(i, j) = list Then
' hledej = True
' Exit Function
' End If
'Next j

End Function
[/VBA]

Jirka_x

[mdmackillop]

Hi Jirka,
A small point, but please use line breaks in long lines of code to avoid the need to scroll.
Regards
MD