Background:
I need to open an Access file and get the information there to make a comparison with the data in my Excel spreadsheet.
I'm using Microsoft Office 15.0 Access db engine Object library instead of Microsoft DAO object library.
Problem:
While I'm available to paste all the data with the following code, for some reason, it starts in "row 2" ignoring titles.
Sub Sample()
Const PathToDB = "C:\...\AccessFile.accdb"
Const TitleSampleTable = "Sample Table"
Dim BDSample As Database
Dim SampleTable As Recordset
Dim SampleTableDef As TableDef
Dim CounterTitles As Long
Dim CounterRows As Long
Dim ColToPasteIn As Long
Dim RowToPasteIn As Long
Set BDSample = DBEngine.Workspaces(0).OpenDatabase(PathToDB)
Set SampleTable = BDSample.OpenRecordset(TitleSampleTable, dbOpenDynaset)
Set SampleTableDef = BDSample.TableDefs(TitleSampleTable)
For CounterTitles = 0 To SampleTableDef.RecordCount
RowToPasteIn = RowToPasteIn + 1
ColToPasteIn = 1
For CounterRows = 0 To SampleTable.Fields.Count
With Sheets(TitleSampleTable)
.Cells(RowToPasteIn, ColToPasteIn).Value = SampleTable.Fields(CounterRows) 'this is starts in the "body" of access, I can't figure a way to retrieve titles!
ColToPasteIn = ColToPasteIn + 1
End With
Next CounterRows
SampleTable.MoveNext
Next CounterTitles
Set BDSample = Nothing
Set SampleTable = Nothing
Set SampleTableDef = Nothing
End Sub
Sample data in Accesss
Sample Data in Excel
Questions:
How do I get the titles values?
You can get the field names and populate the row 1
For i = 0 To SampleTable.Fields.Count - 1
Sheets(TitleSampleTable).Cells(1, i + 1) = SampleTable.Fields(i).Name
Next i
And then you can populate the date from row 2 onward as you were originally doing
Related
I have an Excel VBA macro (Macro A) to export the members' information (Name and Address) from Outlook contacts folder to Excel.
I am trying to retrieve the members of a distribution list, and push them into my Outlook contacts folder on a daily basis. In that case, I can use macro A to export the latest DL members found in my contacts folder.
My ultimate objective is to get the latest name and email address of the members found in a distribution list in Excel format.
I searched online for solutions that can directly export the members of Outlook distribution list to Excel, but didn't achieve my intended effect.
Sub PrintDistListDetails()
Dim olApplication As Object
Dim olNamespace As Object
Dim olContactFolder As Object
Dim olDistListItem As Object
Dim destWorksheet As Worksheet
Dim distListName As String
Dim memberCount As Long
Dim memberIndex As Long
Dim rowIndex As Long
Const olFolderContacts As Long = 10
distListName = "dl.xxxxxx" 'change the name accordingly
Set olApplication = CreateObject("Outlook.Application")
Set olNamespace = olApplication.GetNamespace("MAPI")
Set olContactFolder = olNamespace.GetDefaultFolder(olFolderContacts)
Set olDistListItem = olContactFolder.Items(distListName)
Set destWorksheet = Worksheets.Add
destWorksheet.Range("A1:B1").Value = Array("Name", "Address") 'column headers
memberCount = olDistListItem.memberCount
rowIndex = 2 'start the list at Row 2
'For memberIndex = 1 To memberCount
For memberIndex = 1 To 1
With olDistListItem.GetMember(memberIndex)
destWorksheet.Cells(rowIndex, "a").Value = .Name
destWorksheet.Cells(rowIndex, "b").Value = .Address
End With
rowIndex = rowIndex + 1
Next memberIndex
destWorksheet.Columns.AutoFit
Set olApplication = Nothing
Set olNamespace = Nothing
Set olContactFolder = Nothing
Set olDistListItem = Nothing
Set destWorksheet = Nothing
End Sub
It is only printing out the name of a distribution list, and its "parent email". For example, the output will be "dl.xxxxxx" in A2 cell, and "dl.xxxxxx#outlook.com" in B2 cell, instead of retrieving all the members in the distribution list.
How do I get the latest name and address of the members in a distribution list, and print in Excel using any of the two methods described above?
Your loop only runs once:
For memberIndex = 1 To 1
change it back to
For memberIndex = 1 To memberCount
After going through online forums, I have developed some code to pull data from an X Access database and place within an excel, which is working successfully. From there, I want to take this data and place within another Access database. Think of the excel as the intermediary where, at some point (this is a project given by my boss), the excel will help produce calculations and that info will be taken to the other Access database. For the time being, I just want X Access data to be placed into Y Access sheet. I am having an issue with that placement. In Y Access database I want to head to the last row, insert a row, and place the data within. Sounds easy, but giving me a problem at the end in the DataPost() sub. For the below:
For i = 1 To oSelect.Rows.Count
oRS.AddNew
For j = 1 To oSelect.Columns.Count
oRS.Fields(j) = oSelect.Cells(i, j)
Next j
oRS.Update
Next i
oDB.Close
I am getting a Run-time error 3265 saying Item not found in this collection. I can walk through the code and see the data being selected, but when it gets to the end gives me that error.
I am using DAO connections, code below for the Pull and Post (problem) code. Online I see a lot of other options such as ADO, but I can't add outside of DAO connections I believe. I want to be able to provide the DataPull info as well so you can see my DAO logic I got from some others online.
The SQL Select is much longer, but was having error placing it within this forum so cut it down.
Sub DataPull()
Const DbLoc As String = "C:\WIP\PullSample.accdb"
Dim db As DAO.Database, rs As DAO.Recordset, wkb As Workbook, wks As Worksheet, wks2 As Worksheet, recCount As Long
Dim SQL As String, i As Double, n As Double, lr As Double, t As Double
Set wkb = ActiveWorkbook
Set wks = wkb.Worksheets(1)
Set wks2 = wkb.Worksheets(2)
Set db = OpenDatabase(DbLoc)
SQL = "SELECT [AA-AM].Dates, [AA-AM].[A US Equity]"
SQL = SQL & "FROM [AA-AM] "
SQL = SQL & "WHERE [AA-AM].Dates = Date() "
Set rs = db.OpenRecordset(SQL, dbOpenSnapshot)
wks2.Range("B5").CopyFromRecordset rs
wks2.Range("B5:GG5").Font.Name = "Garamond"
wks2.Range("B5:GG5").Font.Size = 10
wks2.Range("C5:GG5").Copy
wks.Range("D6").PasteSpecial Transpose:=True
Set rs = Nothing
Set wks = Nothing
Set wks2 = Nothing
Set wkb = Nothing
End Sub
Sub DataPost()
Dim oSelect As Range, i As Long, j As Integer, sPath As String
Dim lr as long
Dim wkb As Workbook, wks As Worksheet, wks2 As Worksheet
Dim oDAO As DAO.DBEngine, oDB As DAO.Database
Dim oRS As DAO.Recordset
Const DbLoc As String = "C:\WIP\ProjPullDB.accdb"
Set wkb = ActiveWorkbook
Set wks = wkb.Worksheets(1)
Set wks2 = wkb.Worksheets(2)
Set oSelect = wks2.Range("B5:GG5")
'wks2.Activate
'oSelect.Copy
Set oDAO = New DAO.DBEngine
Set oDB = oDAO.OpenDatabase(DbLoc)
Set oRS = oDB.OpenRecordset("AA-AM")
For i = 1 To oSelect.Rows.Count
oRS.AddNew
For j = 1 To oSelect.Columns.Count
oRS.Fields(j) = oSelect.Cells(i, j)
Next j
oRS.Update
Next i
oDB.Close
End Sub
I expect to be able to place the oSelect data wk2.Range("B5:GG5") data into the Y Access database last row, but no luck.
The error is here
For j = 1 To oSelect.Columns.Count
oRS.Fields(j) = oSelect.Cells(i, j)
Next j
Fields is a zero based array so you are putting the data into the wrong field and when you get to the last column you attempt to access a field that isn't there. You want
For j = 1 To oSelect.Columns.Count
oRS.Fields(j-1) = oSelect.Cells(i, j)
Next j
I'm trying to find the rows with data in my source data sheet and then copy some of the columns into various places in my destination worksheet using VBA. I have successfully done this for a list with 12k lines but when I do some test data, it only copies the first 12 rows out of 19 rows of data....
Sub Header_Raw()
Dim dataBook As Workbook
Dim Header_Raw As Worksheet, Header As Worksheet
Dim dataSource As Range, dataDest As Range
Dim sourceDataRowCount As Integer, index As Integer
Set dataBook = Application.ThisWorkbook
Set sheetSource = dataBook.Sheets("Header_Raw")
Set sheetDest = dataBook.Sheets("Header")
Set dataSource = sheetSource.Range("B4", _
sheetSource.Range("J90000").End(xlUp))
sourceDataRowCount = dataSource.Rows.Count
Set dataDest = sheetDest.Range("B13", "B" & _
sourceDataRowCount)
For index = 1 To sourceDataRowCount
dataDest(index, 1).Value = dataSource(index, 1).Value
dataDest(index, 2).Value = dataSource(index, 2).Value
Next index
End Sub
If you can help tell me what I have done wrong, that would be great
thanks
Julie
Make your life a bit easier with simple debugging. Run the following:
Sub HeaderRaw()
'Dim all the variables here
Set dataBook = Application.ThisWorkbook
Set SheetSource = dataBook.Sheets("Header_Raw")
Set sheetDest = dataBook.Sheets("Header")
Set dataSource = SheetSource.Range("B4", SheetSource.Range("J90000").End(xlUp))
SheetSource.Activate
dataSource.Select
End Sub
Now you will see what is your dataSource, as far as it is selected. Probably it is not what you expect.
I am investigating pulling data from a Notes database directly into Excel as our Finance guy is manually re-typing figures a.t.m.
This is my code so far:
Sub notesBB()
Const DATABASE = 1247
Dim r As Integer
Dim i As Integer
Dim c As Integer
Dim db As Object
Dim view As Object
Dim Entry As Object
Dim nav As Object
Dim Session As Object 'The notes session
Dim nam As Object
Dim val As Variant
Dim v As Double
Dim items As Object
Set Session = CreateObject("Lotus.NotesSession")
Call Session.Initialize
Set nam = Session.CreateName(Session.UserName)
user = nam.Common
Set db = Session.getdatabase("MSPreston", "Billbook1415.nsf")
Set view = db.GetView("By Month\By Dept")
view.AutoUpdate = False
Set nav = view.CreateViewNav
Set Entry = nav.GetFirst
val = Entry.childcount
val = Entry.ColumnValues(6) ' this doesn't work
Set items = Entry.ColumnValues 'from a suggestion on the net
val = items(6) 'this doesn't work either
MsgBox (val)
End Sub
error is "object variable or With Block variable not set"
The annoying thing is that I can see the values I want in the ExcelVBA debug window... so I can't be far off. I guess its how to access an array of items properly
The answer is to declare a variant array and assign it directly...
Sub notesBB()
Const DATABASE = 1247
Dim r As Integer
Dim i As Integer
Dim db As Object
Dim view As Object
Dim Entry As Object
Dim nav As Object
Dim Session As Object 'The notes session
Dim nam As Object ' notes username
Dim v() As Variant ' to hold the subtotal values
Dim bills(12, 16) ' 12 months, 16 departments
r = 1
Worksheets(1).Range("A1:z99").Clear
Set Session = CreateObject("Lotus.NotesSession") 'Start a session to notes
Call Session.Initialize
Set nam = Session.CreateName(Session.UserName)
user = nam.Common
Set db = Session.getdatabase("MSPreston", "Billbook1415.nsf")
Set view = db.GetView("By Month\By Dept")
view.AutoUpdate = False
Set nav = view.CreateViewNav
Set Entry = nav.GetFirst
Do Until Entry Is Nothing
If Entry.isCategory Then
r = r + 1
v = Entry.ColumnValues
For i = 1 To 16
bills(v(0), i) = v(4 + i)
Cells(4 + r, 2 + i) = bills(v(0), i)
Next
End If
Set Entry = nav.getNextCategory(Entry)
DoEvents
Loop
End Sub
This code just extracts the 12 months (rows) by 16 departments (cols) bills values from the Notes view and populates an Excel range with them. Easy when you know (find out) how !
I'm getting said error in using VBA in Excel on the following code:
Private Sub XMLGen(mapRangeA, mapRangeB, ticketSize, mapping)
Dim fieldOneArr As Variant
Dim fieldTwoArr As Variant
Dim row As Long
Dim column As Long
Dim infoCol As Long
Dim endInfo As Long
Dim objDom As DOMDocument
Dim objNode As IXMLDOMNode
Dim objXMLRootelement As IXMLDOMElement
Dim objXMLelement As IXMLDOMElement
Dim objXMLattr As IXMLDOMAttribute
Set ws = Worksheets("StockData")
Dim wsName As String
Set objDom = New DOMDocument
If ticketSize = 8 Then
wsName = "A7Tickets"
ElseIf ticketSize = 16 Then
wsName = "A8Tickets"
Else
wsName = "A5Tickets"
End If
Set ps = Worksheets(wsName)
'create processing instruction
Set objNode = objDom.createProcessingInstruction("xml", "version='1.0' encoding='UTF-8'")
objDom.appendChild objNode
'create root element
Set objXMLRootelement = objDom.createElement("fields")
objDom.appendChild objXMLRootelement
'create Attribute to the Field Element and set value
Set objXMLattr = objDom.createAttribute("xmlns:xfdf")
objXMLattr.NodeValue = "http://ns.adobe.com/xfdf-transition/"
objXMLRootelement.setAttributeNode objXMLattr
infoCol = 1
fieldOneArr = Worksheets(mapping).range(mapRangeA)
fieldTwoArr = Worksheets(mapping).range(mapRangeB)
For row = 1 To UBound(fieldOneArr, 1)
For column = 1 To UBound(fieldOneArr, 2)
'create Heading element
Set objXMLelement = objDom.createElement(fieldOneArr(row, column))
objXMLRootelement.appendChild objXMLelement
'create Attribute to the Heading Element and set value
Set objXMLattr = objDom.createAttribute("xfdf:original")
objXMLattr.NodeValue = (fieldTwoArr(row, column))
objXMLelement.setAttributeNode objXMLattr
objXMLelement.Text = ps.Cells(row, infoCol)
infoCol = infoCol + 1
endInfo = endInfo + 1
If endInfo = 4 Then
infoCol = 1
End If
Next column
Next row
'save XML data to a file
If ticketSize = 2 Then
objDom.Save ("C:\ExportTestA5.xml")
MsgBox "A5 XML created"
ElseIf ticketSize = 8 Then
objDom.Save ("C:\ExportTestA7.xml")
MsgBox "A7 XML created"
Else
objDom.Save ("C:\ExportTestA8.xml")
MsgBox "A8 XML created"
End If
End Sub
When I hit debug it points to this line:
fieldOneArr = Worksheets(mapping).range(mapRangeA)
I know that .Range is supposed to be upper case but it keeps on setting it to lower case automatically whenever I correct it.
This code is meant to create an XML file and then write the details from the chosen worksheet (based on the ticketSize variable) into the correct XML fields. Hence I have a mapping worksheet from which I write the field and attribute names, and then write in the info from the correct ticket size worksheet into the text property of the element.
You should define the types of your function parameters, in this case mapRangeA As String. Office object methods and properties are often not very helpful with their error messages, so it's better to have a type mismatch error if you have a problem with a parameter.