Относительные пути вместо абсолютных в Excel VBA

Просто чтобы прояснить, что сказал yalestar, это даст вам относительный путь:

Workbooks.Open FileName:= ThisWorkbook.Path & "\TRICATEndurance Summary.html"

Вы можете использовать один из них для относительного корня пути:

ActiveWorkbook.Path
ThisWorkbook.Path
App.Path

Я думаю, проблема в том, что открытие файла без указания пути будет работать только в том случае, если ваш «текущий каталог» установлен правильно.

Попробуйте ввести «Debug.Print CurDir» в окне «Немедленное» - в нем должно быть показано расположение файлов по умолчанию, заданное в меню «Инструменты ... Параметры».

Я не уверен, что мне это полностью нравится, возможно, потому что это что-то вроде устаревшей команды VB, но вы могли бы сделать это:

ChDir ThisWorkbook.Path

Думаю, я бы предпочел использовать ThisWorkbook.Path для создания пути к файлу HTML. Я большой поклонник FileSystemObject в среде выполнения сценариев (который, кажется, всегда установлен), поэтому я был бы счастлив сделать что-то вроде этого (после установки ссылки на Microsoft Scripting Runtime):

Const HTML_FILE_NAME As String = "my_input.html"

With New FileSystemObject
    With .OpenTextFile(.BuildPath(ThisWorkbook.Path, HTML_FILE_NAME), ForReading)
        ' Now we have a TextStream object that we can use to read the file
    End With
End With

если текущий каталог операционной системы - это путь к книге, которую вы используете, Workbooks.Open FileName:= "TRICATEndurance Summary.html" будет достаточно. если вы производите вычисления с помощью пути, вы можете ссылаться на текущий каталог как ., а затем \, чтобы указать, что файл находится в этом каталоге, и в случае, если вам нужно изменить текущий каталог ОС на путь к вашей книге, вы можете использовать ChDrive и ChDir для этого.

ChDrive ThisWorkbook.Path
ChDir ThisWorkbook.Path
Workbooks.Open FileName:= ".\TRICATEndurance Summary.html"

Вы можете предоставить пользователям больше возможностей, предоставив им кнопку браузера.

Private Sub btn_browser_file_Click()
Dim xRow As Long
Dim sh1 As Worksheet
Dim xl_app As Excel.Application
Dim xl_wk As Excel.Workbook
Dim WS As Workbook
Dim xDirect$, xFname$, InitialFoldr$
InitialFoldr$ = "C:\"
With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = Application.DefaultFilePath & "\"
    .Title = "Please select a folder to list Files from"
    .InitialFileName = InitialFoldr$
    .Show
    Range("H13").Activate
    If .SelectedItems.Count <> 0 Then
        xDirect$ = .SelectedItems(1) & "\"
         Range("h12").Value = xDirect$
        xFname$ = Dir(xDirect$, 7)
        Do While xFname$ <> ""
         If (Format(FileDateTime(xDirect$ & "\" & xFname$), "MM/DD/YYYY") > Format(Range("H10").Value, "MM/DD/YYYY")) Then
            ActiveCell.Offset(xRow) = xFname$
            xRow = xRow + 1
            xFname$ = Dir
            Else
            xFname$ = Dir
            xRow = xRow
        End If
        Loop
    End If
End With

с помощью этого фрагмента кода вы можете легко этого добиться. Протестированный код

Вот моя быстрая и простая функция для получения абсолютного пути из относительного пути.

Отличие от принятого ответа в том, что эта функция может обрабатывать относительные пути, которые перемещаются к родительским папкам.

Пример:

Workbooks.Open FileName:=GetAbsolutePath("..\..\TRICATEndurance Summary.html")

Код:

' Gets an absolute path from a relative path in the active workbook
Public Function GetAbsolutePath(relativePath As String) As String
    
    Dim absPath As String
    Dim pos As Integer
    
    absPath = ActiveWorkbook.Path
    
    ' Make sure paths are in correct format
    relativePath = Replace(relativePath, "/", "\")
    absPath = Replace(absPath, "/", "\")
    
    Do While Left$(relativePath, 3) = "..\"
    
        ' Remove level from relative path
        relativePath = Mid$(relativePath, 4)
        
        ' Remove level from absolute path
        pos = InStrRev(absPath, "\")
        absPath = Left$(absPath, pos - 1)
    
    Loop
    
    GetAbsolutePath = PathCombine(absPath, relativePath)
    
End Function

я думаю, это может помочь. Ниже макрос проверяет, существует ли папка, если нет, то создает папку и сохраняет в ней форматы xls и pdf. Бывает, что папка используется совместно с вовлеченными людьми, поэтому все обновляются.

Sub PDF_laudo_e_Prod_SP_Sem_Ajuste_Preco()
'
' PDF_laudo_e_Prod_SP_Sem_Ajuste_Preco Macro
'

'


Dim MyFolder As String
Dim LaudoName As String
Dim NF1Name As String
Dim OrigFolder As String

MyFolder = ThisWorkbook.path & "\" & Sheets("Laudo").Range("C9")
LaudoName = Sheets("Laudo").Range("K27")
NF1Name = Sheets("PROD SP sem ajuste").Range("Q3")
OrigFolder = ThisWorkbook.path

Sheets("Laudo").Select
Columns("D:P").Select
Selection.EntireColumn.Hidden = True

If Dir(MyFolder, vbDirectory) <> "" Then
Sheets("Laudo").ExportAsFixedFormat Type:=xlTypePDF, filename:=MyFolder & "\" & LaudoName & ".pdf", Quality:=xlQualityMinimum, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False

Sheets("PROD SP sem ajuste").ExportAsFixedFormat Type:=xlTypePDF, filename:=MyFolder & "\" & NF1Name & ".pdf", Quality:=xlQualityMinimum, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False

ThisWorkbook.SaveAs filename:=MyFolder & "\" & LaudoName

Application.DisplayAlerts = False

ThisWorkbook.SaveAs filename:=OrigFolder & "\" & "Entregas e Instrucao Barter 2015 - beta"

Application.DisplayAlerts = True

Else
MkDir MyFolder
Sheets("Laudo").ExportAsFixedFormat Type:=xlTypePDF, filename:=MyFolder & "\" & LaudoName & ".pdf", Quality:=xlQualityMinimum, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False

Sheets("PROD SP sem ajuste").ExportAsFixedFormat Type:=xlTypePDF, filename:=MyFolder & "\" & NF1Name & ".pdf", Quality:=xlQualityMinimum, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False

ThisWorkbook.SaveAs filename:=MyFolder & "\" & LaudoName

Application.DisplayAlerts = False

ThisWorkbook.SaveAs filename:=OrigFolder & "\" & "Entregas e Instrucao Barter 2015 - beta"

Application.DisplayAlerts = True

End If

Sheets("Laudo").Select
Columns("C:Q").Select
Selection.EntireColumn.Hidden = False
Range("A1").Select

End Sub

Возможно, это не лучший способ сделать это. Но единственное, что я нашел для получения абсолютного пути, - это вычислить, сколько раз синтаксис .. был в строке, а затем использовать функцию gotoparent столько раз, сколько синтаксис встречается в адресе гиперссылки. (в моем случае мое поле является адресом гиперссылки. Ps: для этого кода требуется ссылка на среду выполнения сценариев Microsoft

Function AbsolutePath(strRelativePath As String, strCurrentFileName As String) As String
Dim fso As Object
Dim strCurrentProjectpath As String
Dim strGoToParentFolder As String
Dim strOrigineFolder As String
Dim strPath As String
Dim lngParentFolder As Long


''Pour retrouver le répertoire parent
Set fso = CreateObject("Scripting.FileSystemObject")

'' détermine le répertire du projet actif
strCurrentProjectpath = CurrentProject.Path

'' détermine le nom du répertoire dans lequel le fichier d'origine se trouve
strOrigineFolder = Replace(Replace(Replace(strRelativePath, strCurrentFileName, ""), "..", ""), "\", "")

''Extraction du chemin relatif (ex. ..\..\..)
strGoToParentFolder = Replace(Replace(strRelativePath, strOrigineFolder, ""), strCurrentFileName, "")

''retourne le nombre de fois qu'il faut remonter au répertoire parent
lngParentsFolder = Len(Replace(strGoToParentFolder, "\", "")) / 2

''détermine la valeur d'origine du répertoire du début
strPath = strCurrentProjectpath

Vérifie s 'il faut aller au répertoire parent
If lngParentsFolder < 1 Then
    'si non, alors répertoire parent et répertoire d'origine du fichier
    strPath = strCurrentProjectpath & "\" & strOrigineFolder
Else
    ''si oui, nous faisons la boucle pour retourner au répertoire d'origine
    For i = 1 To lngParentsFolder
        strPath = fso.GetParentFolderName(strPath)
    Next i
End If

''retournons le répertoire parent du fichier et son répertoire d'origine [le OUTPUT]
AbsolutePath = strPath & strOrigineFolder & "\"

End Function