Pregunta

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

I have written this code in VBA Excel to backup data into access from excel. The code doesn't like the way that I wrote the range in my for each loops. I also tried the 2nd for each loop, but that just backed up the main page repeatedly( with the correct table names though).

I think the 1st way is close, but I don't understand what is wrong with FullRange line which is type Range.

EDIT: The error is object variable or with block variable not set on the FullRange line

Update 6-18, It seems that the fullrange should be in the form string. I have edited a little but the error I am getting now on the transferspreadsheet line is "The Microsoft database engine could not find the object'1301 Array$A$1:J$12'. Make sure that the object exists and you spell its name correctly.

I took out fullrange and put in page.name and it gave me the same error.

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  
¿Fue útil?

Solución

I have modified your code a bit, have a look see if you can see where youve gone wrong.

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

Otros consejos

Here is some working code, the range has to have a ! in it for some reason.

  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
Licenciado bajo: CC-BY-SA con atribución
No afiliado a StackOverflow
scroll top