Converting Excel Code to run from Access 1

[Vittles]

I have a database form that is set up as an interface for importing data from an excel worksheet (the worksheet is generated from a different/larger system with a lot of data I do not want imported). When the user selects the appropriate file (me.admin_link) and clicks an 'import data' button, the code should open the excel file, perform the excel data clean-up functions, then import the data from the sheet into the related Access table.

The following is the 'clean-up' coding that I had initially set up as a macro in Excel. I would like to run this code from Access instead (this way eliminating the need for a separate macro outside the database). This code actually ran very well the first time I tried it, but now I am getting possible corruption errors about not having a For before a Next, etc.

Can anyone help me 'clean-up this code'? I believe the c.value reference is what is causing the problems...but any ideas would be great.

Code:

Dim strFileName As String
Dim xlApp As Excel.Application
Set xlApp = New Excel.Application
xlApp.Visible = True
xlApp.Workbooks.Open Me.Admin_Link

For Each c In Worksheets("Data").Range("A2:A1000").Cells
If (Mid(c.Value, 8) = "") Then c.Value = ""
Next

xlApp.Columns("B:B").Select
xlApp.Selection.Delete Shift:=xlToLeft
xlApp.Columns("F:F").Select
xlApp.ActiveWindow.LargeScroll ToRight:=1
xlApp.Columns("F:Q").Select
xlApp.Selection.Delete Shift:=xlToLeft
xlApp.ActiveWindow.SmallScroll ToRight:=3
xlApp.Columns("H:M").Select
xlApp.Selection.Delete Shift:=xlToLeft
xlApp.Columns("J:J").Select
xlApp.ActiveWindow.SmallScroll ToRight:=3
xlApp.Columns("J:N").Select
xlApp.Selection.Delete Shift:=xlToLeft
xlApp.Columns("L:S").Select
xlApp.Selection.Delete Shift:=xlToLeft
xlApp.Columns("N:N").Select
xlApp.ActiveWindow.SmallScroll ToRight:=4
xlApp.Columns("N:V").Select
xlApp.Selection.Delete Shift:=xlToLeft
xlApp.Columns("P").Select
xlApp.Sheets("AbstractExtract").Select
xlApp.Columns("F:F").Select
xlApp.Selection.Copy
xlApp.Sheets("Data").Select
xlApp.Columns("P").Select
xlApp.ActiveSheet.Paste

xlApp.Sheets(Array("AbstractExtract", "ReportCriteria", "Extract3", "Sheet5", _
"R&R Stage Definitions")).Select
xlApp.Sheets("AbstractExtract").Activate
xlApp.ActiveWindow.SelectedSheets.Delete

xlApp.Columns("B").Select

For Each c In Selection
If c.Hyperlinks.Count > 0 Then
txt = c.Hyperlinks(1).Address
c.Value = txt
Next

For Each c In Worksheets("Data").Range("B").Cells
If c.Value = "N/A" Then c.Value = ""
Next
For Each c In Worksheets("Data").Range("F2:F1000").Cells
If c.Value > "" Then c.Value = StrConv(c, vbProperCase)
Next
For Each c In Worksheets("Data").Range("J2:J1000").Cells
If c.Value > "" Then c.Value = StrConv(c, vbProperCase)
Next

xlApp.ActiveWorkbook.Save
xlApp.ActiveWorkbook.Close
Set xlApp = Nothing

Thanks!!

 

[Vittles]

At the end of the day, this is the code that seems to be working - open for any ideas for easier ways/shorter coding:

Dim strFileName As String
Dim xlApp As Excel.Application
Set xlApp = New Excel.Application
xlApp.Visible = True
xlApp.Workbooks.Open Me.Admin_Link

For Each c In xlApp.Worksheets("Data").Range("A2:A600").Cells
If (Mid(c.Value, 8) = "") Then c.Value = ""
Next

xlApp.Columns("B:B").Select
xlApp.Selection.Delete Shift:=xlToLeft
xlApp.Columns("F:F").Select
xlApp.ActiveWindow.LargeScroll ToRight:=1
xlApp.Columns("F:Q").Select
xlApp.Selection.Delete Shift:=xlToLeft
xlApp.ActiveWindow.SmallScroll ToRight:=3
xlApp.Columns("H:M").Select
xlApp.Selection.Delete Shift:=xlToLeft
xlApp.Columns("J:J").Select
xlApp.ActiveWindow.SmallScroll ToRight:=3
xlApp.Columns("J:N").Select
xlApp.Selection.Delete Shift:=xlToLeft
xlApp.Columns("L:S").Select
xlApp.Selection.Delete Shift:=xlToLeft
xlApp.Columns("N:N").Select
xlApp.ActiveWindow.SmallScroll ToRight:=4
xlApp.Columns("N:V").Select
xlApp.Selection.Delete Shift:=xlToLeft
xlApp.Columns("P").Select
xlApp.Sheets("AbstractExtract").Select
xlApp.Columns("F:F").Select
xlApp.Selection.Copy
xlApp.Sheets("Data").Select
xlApp.Columns("P").Select
xlApp.ActiveSheet.Paste

xlApp.Sheets(Array("AbstractExtract", "ReportCriteria", "Extract3", "Sheet5", _
"R&R Stage Definitions")).Select
xlApp.Sheets("AbstractExtract").Activate
xlApp.ActiveWindow.SelectedSheets.Delete

For Each c In xlApp.Worksheets("Data").Range("F2:F600").Cells
If c.Value > "" Then c.Value = StrConv(c, vbProperCase)
Next

For Each c In xlApp.Worksheets("Data").Range("J2:J600").Cells
If c.Value > "" Then c.Value = StrConv(c, vbProperCase)
Next

For Each c In xlApp.Worksheets("Data").Range("B2600").Cells
If c.Hyperlinks.Count > 0 Then c.Value = c.Hyperlinks(1).Address
If c.Value = "N/A" Then c.Value = ""
Next

xlApp.ActiveWorkbook.Save
xlApp.ActiveWorkbook.Close
Set xlApp = Nothing

 

[SkipVought]

Hi,

I don't much care for deleting columns of data. I'd use MS Query to return the columns I wanted the user to see. faq68-5829

But here's your code, cleaned up a tad...

Sub test()
    Dim strFileName As String
    Dim xlApp As Excel.Application
    Set xlApp = New Excel.Application
    xlApp.Visible = True
    xlApp.Workbooks.Open Me.Admin_Link
    
    With xlApp.Worksheets("Data")
    
        For Each c In .Range("A2:A600").Cells
            If (Mid(c.Value, 8) = "") Then c.Value = ""
        Next
        
        .Columns("B:B").Delete Shift:=xlToLeft
        .Columns("F:Q").Delete Shift:=xlToLeft
        .Columns("H:M").Delete Shift:=xlToLeft
        .Columns("J:N").Delete Shift:=xlToLeft
        .Columns("L:S").Delete Shift:=xlToLeft
        .Columns("N:V").Delete Shift:=xlToLeft
        
        xlApp.Sheets("AbstractExtract").Columns("F:F").Copy .Columns("P:P")
            
        xlApp.Sheets(Array("AbstractExtract", "ReportCriteria", "Extract3", "Sheet5", _
                "R&R Stage Definitions")).Delete
                
        For Each c In .Range("F2:F600").Cells
            If c.Value > "" Then c.Value = StrConv(c, vbProperCase)
        Next
          
        For Each c In .Range("J2:J600").Cells
            If c.Value > "" Then c.Value = StrConv(c, vbProperCase)
        Next
         
        For Each c In .Range("B2:D600").Cells
            If c.Hyperlinks.Count > 0 Then c.Value = c.Hyperlinks(1).Address
            If c.Value = "N/A" Then c.Value = ""
        Next
    End With
    
    xlApp.ActiveWorkbook.Save
    xlApp.ActiveWorkbook.Close
    Set xlApp = Nothing

End Sub

Skip,
[sub]
When a diminutive clarvoyant had disappeared from detention, headlines read...
Small Medium at Large[/sub]

 

[Vittles]

Thanks for cleaning it up for me. I am just starting to play around with running excel macro code through access, so it is really nice to see the ways to shorten it. It works really nice for end users as they don't need to do anything but download the original file & then click a button on an access form.

Thanks again!!