William Benson (VBACreations.Com)
vbacreations at gmail.com
Thu Jun 30 17:42:59 CDT 2011
You can set a reference to Excel in the Access vba project, or use late
binding. Assuming you have set a reference you can use code, it's pretty
easy. My recent project is to look for sheets in open files (or let the user
open other filed), and populate combo boxes with workbook names, worksheet
names, and column headers.
Caveats: Methods like Union () need xl.Union to be invokable. Same with
Intersection, and Selection. It's hard to remember this. Trust me. Painful.
If you use late binding you need values for all intrinsic constants. You
also have to watch out for version changes and the impact on intrinsic
constants.
On a Access form I have these objects.
cmdNewWB
combo0 - holds workbook names and # sheets that have data (based on row 1)
combo2 - holds worksheet names and number of data columns (based on filled
columns)
lstFields - holds field names (row headers in each column)
Then play with the combos after the form launches.
Option Compare Database
Option Explicit
Dim m_b_XLLaunched As Boolean
Dim m_b_OpeningWorkbook As Boolean
Dim bAfterUpdateCombo0Fired As Boolean
Dim bAfterUpdateCombo2Fired As Boolean
Private Function GetSelectedFile(Optional ExtensionStringWithPipeSeparator)
As String
Dim iFileTypes As Long
Dim fDialog As Office.FileDialog
Dim varFile As Variant
Dim strTypes As String
Dim strFilters As String
Dim strTemp As String
Dim strParseThis As String
Dim ItemsSkipped()
Dim strSkipped As String
Dim i As Long
strFilters = ""
strTypes = ""
ReDim ItemsSkipped(0)
If Not IsMissing(ExtensionStringWithPipeSeparator) Then
strParseThis = CStr(ExtensionStringWithPipeSeparator)
Else
strParseThis = "*.*"
End If
If strParseThis <> "*.*" Then
Do Until InStr(strParseThis, "|") = 0
strTemp = Left(strParseThis, InStr(strParseThis, "|") - 1)
strParseThis = Mid(strParseThis, Len(strTemp) + 2)
strTemp = Replace$(strTemp, "*.", "")
UpdateFilterAndType strTypes:=strTypes, strFilters:=strFilters,
strTemp:=strTemp, ItemsSkipped:=ItemsSkipped
Loop
strTemp = Replace$(strParseThis, "*.", "")
UpdateFilterAndType strTypes:=strTypes, strFilters:=strFilters,
strTemp:=strTemp, ItemsSkipped:=ItemsSkipped
Else
strTypes = strTypes & ";*.*"
strFilters = strFilters & ",All Files"
End If
If UBound(ItemsSkipped) > 0 Then
strSkipped = ""
For i = 1 To UBound(ItemsSkipped)
strSkipped = strSkipped & Chr(13) & "'" & ItemsSkipped(i) & "'"
Next
strSkipped = Mid(strSkipped, 2)
MsgBox "Known file Type List not comprehensive enough to accommodate
extension(s):" & Chr(13) & Chr(13) & strSkipped
End If
If strTypes <> "" Then
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
fDialog.AllowMultiSelect = False
fDialog.Title = "Select a file to examine"
fDialog.Filters.Clear
fDialog.Filters.Add Mid(strFilters, 2), Mid(strTypes, 2)
If fDialog.Show <> True Then
MsgBox "You clicked Cancel in the file dialog box."
GoTo Exit_Me
Else
Set varFile = fDialog.SelectedItems
GetSelectedFile = varFile(1)
End If
Else
MsgBox "No Accepted File Types Were Specified!", vbInformation
GetSelectedFile = ""
End If
Exit_Me:
End Function
Private Sub cmdNewWB_Click()
Dim xl As Excel.Application
Dim strFile As String
Dim FSO As FileSystemObject
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Dim Col1 As New Collection
Dim Col2 As New Collection
'MakeThisSheetCSV GetXL.ActiveWorkbook.ActiveSheet
'End
Set xl = GetXL
strFile = GetSelectedFile("xl*")
On Error Resume Next
Set wb = xl.Workbooks.Open(strFile)
If Not wb Is Nothing Then
m_b_OpeningWorkbook = True
PopulateWBCombo FindThis:=wb.Name
End If
On Error GoTo 0
Exit_Me:
End Sub
Function PopulateWBCombo(Optional FindThis)
Dim xl As Excel.Application
Dim wb As Excel.Workbook
Dim ws As Worksheet
Dim CountDataSheets As Long
Dim i As Long
Set xl = GetXL
Combo0.RowSourceType = "Value List"
Combo0.RowSource = ""
Combo0.Requery
For Each wb In xl.Workbooks
If wb.Windows(1).Visible Then
CountDataSheets = 0
For Each ws In wb.Worksheets
If LastRow(, , ws) > 1 Then
If xl.WorksheetFunction.CountA(ws.Rows(1)) > 0 Then
CountDataSheets = CountDataSheets + 1
End If
End If
Next
If CountDataSheets > 0 Then
Combo0.AddItem wb.Name & ";" & CountDataSheets
Else
If m_b_OpeningWorkbook Then
MsgBox "'" & wb.Name & "' has no data sheets ... closing it",
vbInformation
wb.Close savechanges:=False
End If
End If
End If
Next
If Not IsMissing(FindThis) Then
Combo0.Value = Combo0.Column(0, Combo0.ListCount - 1)
If Not bAfterUpdateCombo0Fired Then
Call Combo0_AfterUpdate
End If
Else
Combo0.Value = Combo0.Column(0, 1)
If Not bAfterUpdateCombo0Fired Then
Call Combo0_AfterUpdate
End If
End If
bAfterUpdateCombo0Fired = False
End Function
Function PopulateWSCombo()
Dim strFile As String
Dim ws As Excel.Worksheet
Dim wb As Excel.Workbook
Dim xl As Excel.Application
Set xl = GetXL
Combo2.RowSourceType = "Value List"
Combo2.RowSource = ""
Combo2.Requery
lstFields.RowSourceType = "Value List"
lstFields.RowSource = ""
lstFields.Requery
If Combo0.ListCount > 0 Then
If Combo0.ListIndex <> -1 Then
On Error Resume Next
Set wb = xl.Workbooks(Combo0.Column(0, Combo0.ListIndex))
If Not wb Is Nothing Then
For Each ws In wb.Worksheets
If LastRow(, , ws) > 1 Then
If xl.WorksheetFunction.CountA(ws.Rows(1)) > 0 Then
Combo2.AddItem ws.Name & ";" &
xl.WorksheetFunction.CountA(ws.Rows(1)) & " Cols"
Else
End If
End If
Next
Else
MsgBox "Workbook '" & Combo0.Column(0, Combo0.ListIndex) & "' no
longer open", vbInformation
PopulateWBCombo xl
End If
End If
End If
If Combo2.ListCount > 0 Then
Combo2.Value = Combo2.Column(0, 0)
If Not bAfterUpdateCombo2Fired Then
Call Combo2_AfterUpdate
End If
Else
Combo2.Value = ""
If Not bAfterUpdateCombo2Fired Then
Call Combo2_AfterUpdate
End If
End If
bAfterUpdateCombo2Fired = False
End Function
Private Sub PopulateDataColumnList()
Dim wb As Excel.Workbook
Dim ws As Worksheet
Dim CountDataSheets As Long
Dim i As Long
Dim cell As Object
Dim xl As Excel.Application
Set xl = GetXL
lstFields.RowSourceType = "Value List"
lstFields.RowSource = ""
lstFields.Requery
If Combo2.ListIndex <> -1 And Combo0.ListIndex <> -1 Then
On Error Resume Next
If Not xl Is Nothing Then
Set wb = xl.Workbooks(Combo0.Column(0, Combo0.ListIndex))
If Not wb Is Nothing Then
Set ws = wb.Worksheets(Combo2.Column(0, Combo2.ListIndex))
If Not ws Is Nothing Then
For Each cell In ws.Range(ws.Cells(1, 1), ws.Cells(1,
ws.Columns.Count).End(-4159))
If Not IsEmpty(cell) Then
lstFields.AddItem cell
End If
Next
End If
End If
End If
End If
End Sub
Private Sub cmdRefresh_Click()
Call Form_Load
End Sub
Private Sub Combo0_AfterUpdate()
PopulateWSCombo
bAfterUpdateCombo0Fired = True
End Sub
Private Sub Combo2_AfterUpdate()
PopulateDataColumnList
bAfterUpdateCombo2Fired = True
End Sub
Private Sub Form_Load()
PopulateWBCombo
End Sub
Function GetXL() As Excel.Application
On Error Resume Next
Set GetXL = GetObject(, "Excel.Application")
If GetXL Is Nothing Then
m_b_XLLaunched = False
Set GetXL = CreateObject("Excel.Application")
If GetXL Is Nothing Then
MsgBox "Cannot create instance of Excel - aborting"
GoTo Exit_Me
Else
m_b_XLLaunched = True
End If
Else
m_b_XLLaunched = False
End If
GetXL.Visible = True
AppActivate "Microsoft Access"
Exit_Me:
Exit Function
End Function
Function MakeThisSheetCSV(WKS1 As Excel.Worksheet)
Dim WB1 As Excel.Workbook
Dim xl As Excel.Application
Set xl = WKS1.Application
Set WB1 = WKS1.Parent
WKS1.Copy
WKS1.UsedRange.Copy
'WS2.Range(WS1.UsedRange.Address).Select
xl.ActiveWorkbook.ActiveSheet.Range(WKS1.UsedRange.Address).Select
xl.ActiveWorkbook.ActiveSheet.Paste
On Error Resume Next
Kill Environ("Temp") & "\tempcsv.csv"
xl.ActiveWorkbook.SaveAs FileName:=Environ("Temp") & "\tempcsv.csv",
FileFormat:=6
xl.ActiveWorkbook.Close savechanges:=False 'closes csv
End Function