DoCmd.TransferSpreadsheet acImport error＆＃34;外部表格不是预期的格式＆＃34;

时间：2018-02-14 18:55:14

标签： vba excel-vba ms-access excel

您好我收到此错误

  

＆＃34;外部表格不是预期的格式＆＃34;

...当我尝试将Excel数据传输到访问表时。我在文本文件中有数据有一个描述字段。为了避免在250个字符限制下截断，我将文本文件转换为EXCEL，然后将excel传输到访问数据库。但是我得到了这个错误....我在我的机器上安装了excel 2010和2016。提前谢谢。

Sub ImportPPDE_v2()

Dim fDialog As Office.FileDialog
Dim strNewPath As String

On Error GoTo GameOver

Set fDialog = Application.FileDialog(msoFileDialogFilePicker)

'Set up the fDialog variable
'Set the Title, add a filter for text files, and set the initial filepath we want to look at, we are defaulting to the Clarity Extract folder
fDialog.Filters.Clear
fDialog.Title = "Select Latest Project Portfolio Data Extract File"
fDialog.Filters.Add "*.txt", "*.txt"
fDialog.InitialFileName = "G:\Clarity EPPM Extracts\"
fDialog.AllowMultiSelect = False
fDialog.Show

'turn off warnings, we don't need to see this
DoCmd.SetWarnings False

'Check to make sure a file has been selected, and if so that the Project Portfolio Data Extract file has been selected
If fDialog.SelectedItems.Count = 0 Then
    MsgBox "No File has been selected. Load actions have been cancelled.", , "No File Selected"
    GoTo GameOver
ElseIf InStr(1, fDialog.SelectedItems(1), "Project Portfolio Data extract_") = 0 Then
    MsgBox "The file selected appears to be incorrect. It should be the   Data Extract file.  Load actions have been cancelled.", , "ERROR OCCURRED IN DATA LOAD"
    GoTo GameOver
End If

'First delete everything currently in the table
DoCmd.RunSQL "Delete * from tbl_Project_Portfolio_Data_Load"


'DoCmd.TransferText , "Spec_PPDE", "tbl_Project_Portfolio_Data_Load", fDialog.SelectedItems(1)

'First isolate the file name from the selected path, then change the file extension to .xls
strNewPath = Right(fDialog.SelectedItems(1), Len(fDialog.SelectedItems(1)) - InStrRev(fDialog.SelectedItems(1), "\"))
strNewPath = "C:\" & Left(strNewPath, Len(strNewPath) - 4) & ".xlsx"

'Copy the Portfolio data extract file to the user's C: drive as a .xls file
Call SaveAsFile(CStr(fDialog.SelectedItems(1)), strNewPath)

'Now import the new data as selected above
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, "tbl_Project_Portfolio_Data_Load", strNewPath, True

'Now update the Load_Date to be today
DoCmd.RunSQL "Update tbl_Project_Portfolio_Data_Load set [Load Date] = #" & Date & "# Where [Load Date] IS NULL"

'Let the user know the process finished successfully
MsgBox "Project Portfolio Data Extract Data has been uploaded", , "Victory!"

GameOver:

'Turn our warnings back on
DoCmd.SetWarnings True

'Set this back to nothing
Set fDialog = Nothing

'Check if an error occurred that would prevent the expected data from being loaded
If Err.Number <> 0 Then
    MsgBox Err.Description
End If

End Sub

当我的代码尝试将Excel工作表转移到空表中时，我得到了这个错误

这里保存为代码

Sub SaveAsFile(currpath As String, newpath As String)

Dim wb As Workbook, strWB As String
Dim NewWB As String

'The purpose of this module is to copy a file from a given filepath to a user's C: Drive.
'It is also converting the file from .txt to a .xls format
'This is originally intended to be used with the Project Portfolio Data Extract load

'Delete any existing workbook that is there now with the same name
On Error Resume Next
Kill newpath
On Error GoTo GameOver

'Open the current file
Set wb = Workbooks.Open(currpath)

'MsgBox wb.FileFormat
'Application.DisplayAlerts = False

'Save it as a .xls file
wb.SaveAs newpath, xlNormal

'Application.DisplayAlerts = True
'MsgBox wb.FileFormat

'Close the workbook
wb.Close False

GameOver:

Set wb = Nothing

End Sub

1 个答案:

答案 0 :(得分：1)

如果你真的无法在没有截断的情况下链接到文本文件（我可以），并且由于简单的Open不起作用，请将文本文件导入Excel然后另存为Excel工作簿。我使用Excel宏录制器生成一些代码并适应Access过程。 

Sub TextToExcel1(currpath As String, newpath As String)
Dim xlx As Excel.Application, xlw As Excel.Workbook, xls As Excel.Worksheet
Dim blnEXCEL As Boolean
If Dir(newpath) <> "" Then Kill newPath
blnEXCEL = False
On Error Resume Next
Set xlx = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
    Set xlx = CreateObject("Excel.Application")
    blnEXCEL = True
End If
Err.Clear
xlx.Visible = False
Set xlw = xlx.Workbooks.Add
Set xls = xlw.Worksheets("Sheet1")
With xls.QueryTables.Add("TEXT;" & currPath, Range("$A$1"))
    .Name = "Test"
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .TextFilePromptOnRefresh = False
    .TextFilePlatform = 437
    .TextFileStartRow = 1
    .TextFileParseType = xlDelimited
    .TextFileTextQualifier = xlTextQualifierDoubleQuote
    .TextFileConsecutiveDelimiter = True
    .TextFileTabDelimiter = False
    .TextFileSemicolonDelimiter = False
    .TextFileCommaDelimiter = False
    .TextFileSpaceDelimiter = True
    .TextFileColumnDataTypes = Array(1, 1)
    .TextFileTrailingMinusNumbers = True
    .Refresh BackgroundQuery:=False
End With
xlw.SaveAs newPath
Set xls = Nothing
xlw.Close False
Set xlw = Nothing
If blnEXCEL = True Then xlx.Quit
Set xlx = Nothing
End Sub

然后是这个版本：

Sub TextToExcel2(currpath As String, newpath As String)
Dim xlx As Excel.Application
Dim blnEXCEL As Boolean
If Dir(newpath) <> "" Then Kill newPath
blnEXCEL = False
On Error Resume Next
Set xlx = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
    Set xlx = CreateObject("Excel.Application")
    blnEXCEL = True
End If
Err.Clear
xlx.Visible = False
xlx.Workbooks.OpenText filename:=currPath, Origin:=437, StartRow:=1, _
    DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
    ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, 
    Comma:=False, Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), _
    Array(2, 1)), TrailingMinusNumbers:=True
xlx.ActiveWorkbook.SaveAs filename:=newPath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
If blnEXCEL = True Then xlx.Quit
Set xlx = Nothing
End Sub

甚至：

Sub TextToExcel3(currpath As String, newpath As String)
Dim xlx As Excel.Application
Dim blnEXCEL As Boolean
If Dir(newpath) <> "" Then Kill newPath
blnEXCEL = False
On Error Resume Next
Set xlx = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
    Set xlx = CreateObject("Excel.Application")
    blnEXCEL = True
End If
Err.Clear
xlx.Workbooks.Open (currpath)
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
    :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
xlx.Visible = False
xlx.ActiveWorkbook.SaveAs filename:=newPath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
If blnEXCEL = True Then xlx.Quit
Set xlx = Nothing
End Sub

我遇到了让版本1一致地复制的问题。版本2和3看起来都很可靠。

相关问题
最新问题