0 
For Each Page In Worksheets
    PageName = Split(Page.Name, " ")
    If UBound(PageName) > 0 Then
        Worksheets(Page.Name).Activate
        lRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
        LCol = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
        Fullrange = Worksheets(Page.Name).Range(Worksheets(Page.Name).Cells(1, 1), _
            Worksheets(Page.Name).Cells(lRow, LCol))
        accappl.DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, _
            Page.Name, strpathxls, True, Fullrange
    End If
Next

Excel からのアクセスにデータをバックアップするために、VBA Excel でこのコードを記述しました。このコードは、for each ループで範囲を記述した方法が好きではありません。2番目のfor eachループも試しましたが、メインページを繰り返しバックアップしました(ただし、正しいテーブル名を使用)。

1つめの方法は近いと思いますが、Range型であるFullRangeラインのどこが悪いのかわかりません。

編集: エラーはオブジェクト変数であるか、ブロック変数が FullRange 行に設定されていません

更新 6-18、フルレンジはフォーム文字列にある必要があるようです。少し編集しましたが、transferspreadsheet 行に表示されるエラーは、「Microsoft データベース エンジンはオブジェクト '1301 Array$A$1:J$12' を見つけられませんでした。オブジェクトが存在し、その名前のスペルが正しいことを確認してください。 .

フルレンジを取り出して page.name に入れたところ、同じエラーが発生しました。

For Each Page In Worksheets
    PageName = Split(Page.Name, " ")
    If UBound(PageName) > 0 Then
        ' Worksheets(Page.Name).Activate - this line is most likely not needed
        lRow = Page.Range("A" & Rows.Count).End(xlUp).Row
        LCol = Page.Cells(2, Columns.Count).End(xlToLeft).Column
        fullRange = Page.Name & Page.Range(Page.Cells(1, 1), _
            Page.Cells(lRow, LCol)).Address
        accappl.DoCmd.TransferSpreadsheet acImport, _
            acSpreadsheetTypeExcel12Xml, Page.Name, strpathxls, True, Page.Name
    End If
Next
4

2 に答える 2

0

私はあなたのコードを少し変更しました。どこが間違っているかを確認してください。

Dim Page As Worksheet
Dim lRow As Long, LCol As Long
Dim fullRange As Range
Dim PageName As Variant

For Each Page In Worksheets

    PageName = Split(Page.Name, " ")

    If UBound(PageName) > 0 Then
        ' Worksheets(Page.Name).Activate - this line is most likely not needed
        lRow = Page.Range("A" & Rows.Count).End(xlUp).Row
        LCol = Page.Cells(1, Columns.Count).End(xlToLeft).Column
        Set fullRange = Page.Range(Cells(1, 1), Cells(lRow, LCol))
        accappl.DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, Page.Name, strpathxls, True, fullRange
    End If
Next
于 2013-06-18T07:17:46.273 に答える
0

ここにいくつかの作業コードがあります。範囲には ! が必要です。その中になぜか。 

  Sub BU_ACCESS()

Dim accappl As Access.Application
Dim strpathdb As String
Dim strpathxls As String
'Dim myrange As String, myrow1 As String, myrow2 As String
'Dim fullRange As Range



strpathdb = "C:\Users\tgfesaha\Desktop\Database1.accdb"
'path to the upload file

strpathxls = ActiveWorkbook.FullName




Set accappl = New Access.Application

accappl.OpenCurrentDatabase strpathdb
Dim Page As Worksheet
Dim lRow As Long, LCol As Long
Dim fullrange As String
Dim PageName As Variant
'fullRange = Worksheets(Page.Name).Range(Worksheets(Page.Name).Cells(1, 1), Worksheets(Page.Name).Cells(lRow, LCol))

For Each Page In Worksheets

    PageName = Split(Page.Name, " ")

    If UBound(PageName) > 0 Then
        ' Worksheets(Page.Name).Activate - this line is most likely not needed
        lRow = Page.Range("A" & Rows.Count).End(xlUp).Row
        LCol = Page.Cells(2, Columns.Count).End(xlToLeft).Column
        fullrange = Page.Range(Page.Cells(1, 1), Page.Cells(lRow, LCol)).Address
        xclam = Page.Name & "!" & fullranges

        accappl.DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, Page.Name, strpathxls, True, xclam
    End If
Next

accappl.Quit

End Sub
于 2013-06-18T16:44:04.837 に答える