打開文件夾中的所有dbf文件並將它們另存爲excel到另一個文件夾中

Question

我有一個包含多個dbf文件的「test」文件夾。我想要vba在excel文件中打開它們並將它們（以excel格式）保存在保存相同dbf文件名的另一個文件夾中。

我在網上發現了這段代碼，並試圖使用這段代碼來滿足我的需求，但它不起作用。錯誤信息：

「的功能子沒有定義」

...請調查一下。

Sub test() 

Dim YourDirectory As String 
Dim YourFileType As String 
Dim LoadDirFileList As Variant 
Dim ActiveFile As String 
Dim FileCounter As Integer 
Dim NewWb As Workbook 

YourDirectory = "c:\Users\navin\Desktop\test\" 
YourFileType = "dbf" 

LoadDirFileList = GetFileList(YourDirectory) 
If IsArray(LoadDirFileList) = False Then 
    MsgBox "No files found" 
    Exit Sub 
Else 
    ' Loop around each file in your directory 
    For FileCounter = LBound(LoadDirFileList) To UBound(LoadDirFileList) 
     ActiveFile = LoadDirFileList(FileCounter) 
     Debug.Print ActiveFile 
     If Right(ActiveFile, 3) = YourFileType Then 
      Set NewWb = Application.Workbooks.Open(YourDirectory & ActiveFile) 
      Call YourMacro(NewWb) 
      NewWb.SaveAs YourDirectory & Left(ActiveFile, Len(ActiveFile) - 4) & ".xlsx" 
      NewWb.Saved = True 
      NewWb.Close 
      Set NewWb = Nothing 
     End If 
    Next FileCounter 
End If 
End Sub 

Answer 1

你缺少的功能GetFileList和YourMacro。快速搜索帶我到這個網站（我認爲你從那裏複製）。 http://www.ozgrid.com/forum/printthread.php?t=56393

有缺失的功能。還複製這兩個在你的模件，使其運行（我用PDF的文件測試吧）：

Function GetFileList(FileSpec As String) As Variant 
' Author : Carl Mackinder (From JWalk) 
' Last Update : 25/05/06 
' Returns an array of filenames that match FileSpec 
' If no matching files are found, it returns False 

Dim FileArray() As Variant 
Dim FileCount As Integer 
Dim FileName As String 

On Error GoTo NoFilesFound 

FileCount = 0 
FileName = Dir(FileSpec) 
If FileName = "" Then GoTo NoFilesFound 

' Loop until no more matching files are found 
Do While FileName <> "" 
     FileCount = FileCount + 1 
     ReDim Preserve FileArray(1 To FileCount) 
     FileArray(FileCount) = FileName 
     FileName = Dir() 
Loop 
    GetFileList = FileArray 
Exit Function 

NoFilesFound: 
    GetFileList = False 
End Function 

Sub YourMacro(Wb As Workbook) 
Dim ws As Worksheet 
Set ws = Wb.Worksheets(1) 
ws.Range("A6").Value = "=((+A2*$CN2)+(A3*$CN3)+(A4*$CN4)+(A5*$CN5))/SUM($CN2:$CN5)" 
ws.Range("A6").Copy ws.Range("B6:CM6") 
ws.Range("CO6").Value = "=CO2" 
End Sub 

要保存在不同的目錄下的文件：

Dim SaveDirectory As String 
SaveDirectory = "c:\Users\navin\Desktop\test\converted to excel" 

替換該行

NewWb.SaveAs YourDirectory & Left(ActiveFile, Len(ActiveFile) - 4) & ".xlsx" 

與此

NewWb.SaveAs SaveDirectory & Left(ActiveFile, Len(ActiveFile) - 4) & ".xlsx"