Question

我编写了一个Excel VBA宏，它在对数据进行计算之前从HTML文件（本地存储）导入数据。

目前使用绝对路径引用HTML文件：

Workbooks.Open FileName:="C:\Documents and Settings\Senior Caterer\My Documents\Endurance Calculation\TRICATEndurance Summary.html"

但是我想使用相对路径来引用它而不是绝对路径（这是因为我想将电子表格分发给可能不使用相同文件夹结构的同事）。由于html文件和excel电子表格位于同一个文件夹中，我不会想到这会很困难，但是我完全无法做到这一点。我在网上搜索过，建议的解决方案都显得很复杂。

我正在使用Excel 2000和2002，但是当我计划分发它时，我希望它能够与尽可能多的Excel版本一起使用。

感激地收到任何建议。

Answer 1

为了澄清耶鲁星所说的话，这会给你相对路径：

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

Answer 2

您可以将其中一个用于相对路径根目录：

ActiveWorkbook.Path
ThisWorkbook.Path
App.Path

Answer 3

我认为问题是只在正确设置“当前目录”的情况下打开没有路径的文件。

尝试在立即窗口中键入“Debug.Print CurDir” - 应显示工具...选项中设置的默认文件的位置。

我不确定我是否对此感到满意，也许是因为它有点像传统的VB命令，但你可以这样做：

ChDir ThisWorkbook.Path

我想我更喜欢使用ThisWorkbook.Path来构建HTML文件的路径。我是Scripting Runtime中的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

Answer 4

通过向他们提供浏览器按钮，您可以为用户提供更多灵活性

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

使用这段代码，您可以轻松实现这一目标。 经过测试的代码

Answer 5

如果操作系统的当前目录是您正在使用的工作簿的路径，则Workbooks.Open FileName:= "TRICATEndurance Summary.html"就足够了。如果要使用路径进行计算，则可以将当前目录引用为.，然后将\引用为该目录中的文件，以防万一必须将os的当前目录更改为您的目录工作簿的路径，您可以使用ChDrive和ChDir来实现。

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

Answer 6

这是我快速而简单的功能，用于从相对路径获取绝对路径。

与接受的答案不同的是，此功能可以处理向上移动到父文件夹的相对路径。

示例：

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

Answer 7

我认为这可能会有所帮助。下面的宏检查文件夹是否存在，如果没有，则创建文件夹并以这种文件夹中的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

Answer 8

这可能不是最好的方法。但是，我发现唯一获得绝对路径的方法是计算语法..在字符串中的次数，然后使用函数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

Excel VBA中的相对而不是绝对路径

8 个答案: