在Excel VBA中重命名文件

Question

我在 SF 论坛上找到了以下 Dos 批处理脚本 用以下命令重命名多个文件在 Dos 批处理文件中，它的工作方式完全按照设计:)

我的问题是我从 Excel VBA 脚本中执行此操作，并且

1. 我必须在 VBA 中构建一个延迟 EG 和 Msgbox，否则VBA 脚本执行速度比 dos 脚本重命名我需要的文件更快，导致找不到文件（它是在我需要时即时完成的）。

2. Excel工作簿打开一个名称在1到800之间的工作表。如果我想打开文件14.csv（根据工作表名称），dos脚本不会有太大帮助，因为它会按顺序重命名文件，所以1,2,3,4,5 而不是 1,2,3,4, 14（或根据需要）。

也许有更好的描述：

我打开一个自动分配数字的工作表（在本例中为工作表 14） - 然后我触发一个 vba 脚本来查找目录中具有特定开头的文件，即“keyw*.csv”，并将其重命名例如“14.csv”，依次导入到其工作表中。在重命名之前，目录中仅存在一个以“keyw*.csv”开头的此类文件。

基本上在我看来，我只能选择 DOS 批处理文件中的不同函数，甚至更好，基于 VBA 宏中的“MoveFile”的函数，但是当我在 VBA 中尝试“MoveFile”时，它没有不认识“*”。

每次我下载文件时，它都以“keywords_blahbla”开头，因此我需要使用通配符来查找它，以便重命名它。 显然我可以轻松地打开目录并单击文件，但我真的很想自动化整个过程，所以你能指导我正确的方向吗？

谢谢

这是我使用的 DOS 批处理：

REM DOS FILE

echo on 光盘\ cd c:\keywords\SOMETHING\

SETLOCAL ENABLEDELAYEDEXPANSION
SET count=3
FOR %%F IN (c:\keywords\SOMETHING\*.csv) DO MOVE "%%~fF" "%%~dpF!count!.csv" & SET /a 

count=!count!+1
ENDLOCAL

这是关联的 VBA 脚本：

Dim vardirfull As String
Dim RetVal
Dim varInput As Variant
Dim fso As Object
vardirfull = Left(ThisWorkbook.Name, InStr(1, ThisWorkbook.Name, ".", vbTextCompare) - 1)
vardir = UCase(vardirfull)
varfil = ActiveSheet.Name
If Range("A2") <> "" Then
ActiveSheet.Range("A2:C1050").ClearContents
Selection.Hyperlinks.Delete
'-----------------------------------------
'using VBA input to open the file:
    'varInput = InputBox("Please enter the NUMBER/NAME highlited at the bottom of this Worksheet or enter 'new' for a new Worksheet")
    'If CStr(varInput) <> CStr(ActiveSheet.Name) Then GoTo MustBeSheetName
'-----------------------------------------  
'using the DOS Batch:
    'RetVal = Shell("C:\keywords\" & vardir & "\changeto3.bat", 1)
    'MsgBox "check1 -  C:\keywords\" & vardir & "\" & varfil & ".csv"
'-----------------------------------------  
'using VBA to search without opening a dialog:(wildcard is not accepted)

Set fso = CreateObject("Scripting.FileSystemObject")
fso.MoveFile "C:\keywords\" & vardir & "\keyw*.csv", "C:\keywords\" & vardir & "\" & vardir & ".csv"
'MsgBox "pause to allow DOS to fully execute(if used)"
If (fso.FileExists("C:\keywords\" & vardir & "\" & varfil & ".csv")) Then
Set fso = Nothing
GoTo Contin
    Else 
MsgBox "No such File"
Exit Sub
End If

Contin:
Range("A2:B2").Select


With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;C:\keywords\" & vardir & "\" & varfil & ".csv", Destination:=Range("$A$2"))

编辑 1

该脚本指出错误“需要常量表达式”，我不明白，因为变量“vardir”已经是已定义

Dim vardirfull As String

vardirfull = Left(ThisWorkbook.Name, InStr(1, ThisWorkbook.Name, ".", vbTextCompare) - 1)
vardir = UCase(vardirfull)

ActiveSheet.Range("A2:C1050").ClearContents
Selection.Hyperlinks.Delete
'-----------------------------------------
Dim sNewFile As String
    Dim sh As Worksheet
    Dim qt As QueryTable
    Dim sConn As String


Const sPATH As String = "C:\magickeys\" & vardir & "\" **'(error:constant expression required**
    Const sKEY As String = "keyw"

    'I'm not sure how your sheet gets named, so I'm naming
    'it explicitly here
    Set sh = ActiveSheet
    'sh.Name = "14"
    sNewFile = sh.Name & ".csv"

    'look for 'keyword' file
    sOldFile = Dir(sPATH & sKEY & "*.csv")

    'if file is found
    If Len(sOldFile) > 0 Then
        'rename it
        Name sPATH & sOldFile As sPATH & sNewFile


    End If

编辑2：已解决

谢谢克里斯:)

在尝试了脚本并整理了一下我的脚本后，它现在功能齐全，

因为工作表名称已通过以下方式分配给任何新工作表在后端，不需要设置名称，但如果有人愿意，我已经包含并注释掉了一个输入变体，因此您只需输入工作表名称，其余部分将自动完成（只需取消注释这些行）。 显然，我在底部遗漏了导入的确切类型，因为每个人都想导入不同的行并更改不同的文件名，只需更改“sKEY”变量即可。

再次感谢克里斯

    Sub RenameandImportNewFile()
    'Dim varInput As Variant
    'varInput = InputBox("Rename this sheet and the File to be imported will be named accordingly or Cancel, vbCancel")
    'If varInput = "" Then Exit Sub
    'ActiveSheet.Name = varInput

    Dim fso As FileSystemObject
    Dim Fl As file
    Dim vardirfull As String
    Dim sPATH As String
    Dim sKEY As String
    Dim sNewFile As String

    vardirfull = Left(ThisWorkbook.Name, InStr(1, ThisWorkbook.Name, ".", vbTextCompare) - 1)
    vardir = UCase(vardirfull)
    sPATH = "C:\magickeys\" & vardir & "\"
    sKEY = "key"
    sh = ActiveSheet.Name
    sNewFile = sPATH & sh & ".csv"
    ActiveSheet.Range("A2:C1050").ClearContents
    Selection.Hyperlinks.Delete
    '-----------------------------------------

    Set fso = CreateObject("Scripting.FileSystemObject")

            If (fso.FileExists(sNewFile)) Then
            GoTo Contin
            Else
            MsgBox "The File : " & sNewFile & " will now be created"
            End If
            sOldFile = sPATH & sKEY & "*.csv"
            '------------------------------------------

            Set fso = New FileSystemObject
                Set Fl = FindFile(fso, "C:\magickeys\" & vardir & "\", "key*.csv")
                If Fl Is Nothing Then
                    MsgBox "No Files Found"
                    Exit sub
                Else
                    MsgBox "Found " & Fl.Name
                If Len(sOldFile) > 0 Then
                    Name Fl As sNewFile
            '------------------------------------------

            Contin:
            With ActiveSheet.QueryTables.Add(Connection:= _
            "TEXT;" & sNewFile, Destination:=Range("$A$2"))

            'here the rows you want to import
        end sub

在子之后包含此功能

Function FindFile(ByRef fso As FileSystemObject, FolderSpec As String, FileSpec As String) As file

    Dim Fld As folder
    Dim Fl As file

    Set Fld = fso.GetFolder(FolderSpec)
    For Each Fl In Fld.Files
        If Fl.Name Like FileSpec Then
            ' return first matching file
            Set FindFile = Fl
            GoTo Cleanup:
        End If
    Next

    Set FindFile = Nothing
Cleanup:
    Set Fl = Nothing
    Set Fld = Nothing
    Set fso = Nothing
End Function

Answer 1

运行批处理文件来执行此操作会使您的代码变得不必要的复杂。全部用 VBA 完成。一个有用的工具是 FileSystemObject

早期绑定，通过设置对脚本类型库 (Scrrun.dll) 的引用来

Dim fso as FileSystemObject
Set fso = New FileSystemObject

后期绑定，如

Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")

文档和在线

编辑： FileSystemObject 方法 有很多关于 SO 的信息使用通配符匹配文件

函数搜索与模式匹配的目录或文件，返回找到的第一个匹配文件

Function FindFile(ByRef fso As FileSystemObject, FolderSpec As String, FileSpec As String) As file

    Dim Fld As Folder
    Dim Fl As file

    Set Fld = fso.GetFolder(FolderSpec)
    For Each Fl In Fld.Files
        If Fl.Name Like FileSpec Then
            ' return first matching file
            Set FindFile = Fl
            GoTo Cleanup:
        End If
    Next

    Set FindFile = Nothing
Cleanup:
    Set Fl = Nothing
    Set Fld = Nothing
    Set fso = Nothing
End Function

使用示例

Sub DemoFindFile()
    Dim fso As FileSystemObject
    Dim Fl As file

    Set fso = New FileSystemObject
    Set Fl = FindFile(fso, "C:\temp", "File*.txt")
    If Fl Is Nothing Then
        MsgBox "No Files Found"
    Else
        MsgBox "Found " & Fl.Name
    End If

    Set Fl = Nothing
    Set fso = Nothing
End Sub

Answer 2

我不完全理解您的工作流程，但希望下面的内容能为您提供足够的信息，使其适应您的情况。

Sub ImportCSV()

    Dim sOldFile As String
    Dim sNewFile As String
    Dim sh As Worksheet
    Dim qt As QueryTable
    Dim sConn As String

    Const sPATH As String = "C:\Users\dick\TestPath\"
    Const sKEY As String = "keyword"

    'I'm not sure how your sheet gets named, so I'm naming
    'it explicitly here
    Set sh = ActiveSheet
    sh.Name = "14"
    sNewFile = sh.Name & ".csv"

    'look for 'keyword' file
    sOldFile = Dir(sPATH & sKEY & "*.csv")

    'if file is found
    If Len(sOldFile) > 0 Then
        'rename it
        Name sPATH & sOldFile As sPATH & sNewFile
        'create connection string
        sConn = "TEXT;" & sPATH & sNewFile
        'import text file
        Set qt = sh.QueryTables.Add(sConn, sh.Range("A2"))
        'refresh to show data
        qt.Refresh
    End If

End Sub