I have some code that allows me to import an excel spreadsheet into a new access table. This has been working great for me for the last year, but today I have started getting strange results. The code performs some basic maintenance on the excel sheet for formatting before importing the data. This has allows worked in the past, but now, the formatting is not sticking. I have stepped through the code and watched the changes take place, but once the data is in access, all the junk data that had been deleted is suddenly back and I can no longer use the data as I need it. Does anyone have any idea why this is happening, and how I might be able to get past this?
The import/formatting code I am using is:
Code:
Option Explicit
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Public Function CreateAccess()
Dim OpenFile As OPENFILENAME
Dim lReturn As Long
Dim sFilter As String
Dim WrksheetName As String
Dim i As Integer
Dim oApp As Object
MsgBox "Please select the saved Weekly Report", vbExclamation, "Attention"
OpenFile.lStructSize = Len(OpenFile)
'OpenFile.hwndOwner = Form.Hwnd
'OpenFile.hInstance = App.hInstance
'sFilter = "acSpreadsheetTypeExcel (*.xlxs)" & Chr(0) & "*.xlxs" & Chr(0)
OpenFile.lpstrFilter = sFilter
OpenFile.nFilterIndex = 1
OpenFile.lpstrFile = String(257, 0)
OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
OpenFile.lpstrFileTitle = OpenFile.lpstrFile
OpenFile.nMaxFileTitle = OpenFile.nMaxFile
OpenFile.lpstrInitialDir = xxxxxxx
OpenFile.lpstrTitle = "Choose a File"
OpenFile.flags = 0
lReturn = GetOpenFileName(OpenFile)
Set oApp = CreateObject("Excel.Application")
oApp.Visible = True
oApp.Workbooks.Open OpenFile.lpstrFile
'Finds the first empty cell in a column
oApp.Range("A1").End(xlDown).Offset(1, 0).Select
'The first few rows of the spreadsheet feature info
'about the filters used from <program>. Not necessary for
'a database. This will delete these rows
oApp.Range(ActiveCell.Row & ":" & ActiveCell.Row).Select
oApp.Range("1:1", ActiveCell.Row & ":" & ActiveCell.Row).Delete
oApp.Range("A1").Select
'Jumps down to the next row Loops through the row until
'there is an empty cell, clearing the color formats and making the
'font black (automatic)
Do
With oApp.Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With oApp.Selection.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
'Finds and replaces spaces with an underscore
oApp.ActiveCell.Value = Replace(ActiveCell.Value, " ", "_")
oApp.ActiveCell.Offset(0, 1).Select
Loop Until IsEmpty(ActiveCell)
'Deletes the last row of data
oApp.Range("A" & Cells(Rows.Count, "A").End(xlUp).Row).Select
oApp.Selection.Delete Shift:=xlUp
With oApp
.Visible = False
DoCmd.TransferSpreadsheet (acImport), acSpreadsheetTypeExcel97, "xxxxxxx", OpenFile.lpstrFile, True
End With
oApp.DisplayAlerts = False
oApp.Workbooks.Close
oApp.DisplayAlerts = True
oApp.Quit
Set oApp = Nothing
End Function