Fetching data from Excel 2

[Aydan]

My data I want to bring over to an Access database is stored in an Excel workbook with as many work sheets as letters in the alphabet. On each sheet I have information about contacts. The info is not stored line by line for each contact but like cards. There are place holders (formatting of cells) for firstname, last name telephone ...) Since the distance between each contact is the same I can do a for loop. The question is, how to define a range in each worksheet to look for information. Some thing like Do while rownumber=10000?
Thanks

 

[BillPower]

Hi Aydan,

This can be done if all the headings e.g. Company Name: and the input areas in relation to the headings are 100% the same. If so, can you post an exact example of how a record appears in your workbook, include the cell ref as shown below.

Company Name: (B2)    Acme Co(D2)
Contact Name:(B3)     Bill Power(D3)
Address:(B5)          My Address Line1(D5)
                      My Address Line2(D6)
                      My Address Line3(D7)
                      My Address Line4(D8)
Post/Zip Code:(B9)    123456(D9)
Telephone:(B11)       123-456-789(D11)
E-mail:(B13)          AcmeCo@bt.com.uk(D13)

Do this for ALL headings and input areas for the example record. Can you suffix all headings with a colon.

 

[Aydan]

Hi bill, thanks for your reply. I'll try to do so, trough the excel sheet was intended to serve as a custormer fidelity card calculator with fields to enter the purchases(10):

A B C
--------------------------------------------------------
Last nameB2)
First nameB3)
Post code/ state: (B4)
Tel: (B5)

Price1A7)->value is in 'C' Value1C7)
Price2A8) "
Price3A9) ...and so on until 10 "

Tis information repeats withs with one empthy row/colum in between (3x near each other(for the row) but defers vertically from worksheet to an other)
I hope I coul make it undertandable, let me know if not!
I have in Access allready my table Contacts and purchases where I made a form for (bases on a joined query) I hope I can bring over this data into this query!
Thanks again.

 

[BillPower]

Hi Aydan,

You've said Last nameB2), is that the heading? Is the text, i.e. the actual name input into (C2) etc.

 

[Aydan]

Yes, sorry for the confusion, the values for Last name, first name, postal code and telephone are in C2, C3, C4, C5. I forgot to mention, at the botton of the purchases there is also a calculated field with the discount, but this will be calculated in access too so I don't need this totals.

 

[BillPower]

Thanks, should be able to post a procedure by this time tomorrow. Just two questions.

1. Approximately how many contacts are we talking about?

2. Are all the contact details in columns A - C or do they go A - C then e.g. F - H etc.?

 

[Aydan]

To answer your question:
1. The amount of contacts vary from worksheet(first letter of the last name), under the letter 'V' there are a lot, let say between the 50-200. On some letters there is no contact information (like letter X). But still there are labeled and formatted for enter information when needed.

2. I have 3 contact cards near each other. They go from A-C then E - G and I - K. The rows are preformatted with labels and lines until row 10.000. (these are not all filled in yet).

Thanks again!
Adyan

 

[BillPower]

Hi Aydan,
Backup your work first!

Paste the code below into a module in your contacts workbook:

Dim i 'variable for sheet counter
Dim intNewSheet As Integer 'variable for new sheet
Dim strCellRef As String 'variable to store first find cell ref
Dim strCurrCellRef 'variable to stord subsequent find cell refs
Dim strLastName As String
Dim strFirstName As String
Dim strPostCode As String
Dim strTelephone As String
Dim varPrice1 As Variant
Dim varPrice2 As Variant
Dim varPrice3 As Variant

Sub GetMyData()
On Error Resume Next
Application.ScreenUpdating = False
Worksheets.Add.Move After:=Worksheets(Worksheets.Count) 'Create new sheet for data
EnterFieldNames 'Enter field names in new sheet
intNewSheet = Sheets.Count 'Get the index for the new sheet
For i = 1 To Sheets.Count – 1 'Counter for amount of sheets in workbook - new sheet
Sheets(i).Select 'select current sheet in counter
FindFirstContact
FindSubsequentContacts
Next i
Worksheets(intNewSheet).Activate 'display the new sheet with your data in it, hopefully
Application.ScreenUpdating = True
End Sub

Function EnterFieldNames() 'Enters field names in first row of new sheet
On Error Resume Next
ActiveWorkbook.Names.Add Name:="DataInputStart", RefersToR1C1:=ActiveCell
ActiveCell.Value = "LastName"
ActiveCell.Offset(0, 1).Value = "FirstName"
ActiveCell.Offset(0, 2).Value = "PostCode"
ActiveCell.Offset(0, 3).Value = "Telephone"
ActiveCell.Offset(0, 4).Value = "Price1"
ActiveCell.Offset(0, 5).Value = "Price2"
ActiveCell.Offset(0, 6).Value = "Price3"
End Function

Function FindFirstContact() 'find the 1st contact and set the strCellRef variable
On Error GoTo FindFirstContactErr
Range("A1&quot.Select
Cells.Find(What:="Last name", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False).Activate
strCellRef = ActiveWindow.RangeSelection.Address
If CheckThatDataEntered = True Then
TransferDataToNewSheet
End If
Exit Function
FindFirstContactErr:
MsgBox "Error no. " & Err.Number & " has occurred. The reason is " & _
Err.Description
Application.ScreenUpdating = True
End Function

Function FindSubsequentContacts() 'finds subsequent contacts until strCellRef = strCellRef
On Error GoTo FindSubsequentContactsErr
strCurrCellRef = vbNullString
While strCellRef <> strCurrCellRef
Cells.Find(What:=&quot;Last name&quot;, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False).Activate
strCurrCellRef = ActiveWindow.RangeSelection.Address
If strCellRef <> strCurrCellRef Then
If CheckThatDataEntered = True Then
TransferDataToNewSheet
End If
End If
Wend
Exit Function
FindSubsequentContactsErr:
MsgBox &quot;Error no. &quot; & Err.Number & &quot; has occurred. The reason is &quot; & _
Err.Description
Application.ScreenUpdating = True
End Function

Function CheckThatDataEntered() 'ignore a contact unless at least 1 field has data.
On Error Resume Next
CheckThatDataEntered = True
strLastName = ActiveCell.Offset(0, 1).Value
strFirstName = ActiveCell.Offset(1, 1).Value
strPostCode = ActiveCell.Offset(2, 1).Value
strTelephone = ActiveCell.Offset(3, 1).Value
varPrice1 = ActiveCell.Offset(5, 1).Value
varPrice2 = ActiveCell.Offset(6, 1).Value
varPrice3 = ActiveCell.Offset(7, 1).Value
If IsNothing(strLastName) And _
IsNothing(strFirstName) And _
IsNothing(strPostCode) And _
IsNothing(strTelephone) And _
IsNothing(varPrice1) And _
IsNothing(varPrice2) And _
IsNothing(varPrice3) Then
CheckThatDataEntered = False
End If
End Function

Function TransferDataToNewSheet() 'transfer contact data to new sheet
On Error Resume Next
Worksheets(intNewSheet).Activate
Range(&quot;DataInputStart&quot.Select
ActiveCell.Offset(1, 0).Select
ActiveWorkbook.Names.Add Name:=&quot;DataInputStart&quot;, RefersToR1C1:=ActiveCell
ActiveCell.Value = strLastName
ActiveCell.Offset(0, 1).Value = strFirstName
ActiveCell.Offset(0, 2).Value = strPostCode
ActiveCell.Offset(0, 3).Value = strTelephone
ActiveCell.Offset(0, 4).Value = varPrice1
ActiveCell.Offset(0, 5).Value = varPrice2
ActiveCell.Offset(0, 6).Value = varPrice3
Worksheets(i).Select
End Function

Function IsNothing(varV As Variant) As Integer 'see Thread181-427974 for details
IsNothing = False
Select Case VarType(varV)
Case vbEmpty
IsNothing = True
Case vbNull
IsNothing = True
Case vbString
If Len(varV) = 0 Then
IsNothing = True
End If
Case Else
IsNothing = False
End Select
End Function

To create a new module, press Alt+F11 on your keyboard simultaneously, this will open the Visual Basic Editor, on the menu, select Insert, then Module, paste the code above, everything coloured blue. Save the your file. Close the VBE.

To run the procedure, press Alt+F8 on your keyboard simultaneously, then double click on GetMyData in the macro name window, hopefully in a few moments you should have a new sheet added to your workbook with your records formatted, ready to be imported into Access.

If all goes well the 1st time, let me know if you need any help getting the data into Access. If it doesn't can you post any Error numbers that you get and their description.

Good Luck!

 

[Aydan]

Hi Bill,
Thank you for the job you've done!!
I have copied the code above and pasted in a new module in my workbook. After pasting I noted that the line where the 'for i =' statement begins in sub GetMyData() was red. When I tryed to modify the line to get a message by removing a space and type it back and move to the next line it gives me a compile error with message: Expected: end of statment.
I could not immeditately see where the error could be, all seem ok. I hope you see the problem!

 

[BillPower]

Hi Aydan,

This is an odd one, either re-type the - 1 in the line below:

For i = 1 To Sheets.Count - 1 'Counter for amount of sheets in workbook - new sheet

Or try copying this part of the code again:

Sub GetMyData()
On Error Resume Next
    Application.ScreenUpdating = False
    Worksheets.Add.Move After:=Worksheets(Worksheets.Count) 'Create new sheet for data
    EnterFieldNames                    'Enter field names in new sheet
    intNewSheet = Sheets.Count         'Get the index for the new sheet
        For i = 1 To Sheets.Count - 1  'Counter for amount of sheets in workbook - new sheet
            Sheets(i).Select           'select current sheet in counter
            FindFirstContact
            FindSubsequentContacts
        Next i
    Worksheets(intNewSheet).Activate   'display the new sheet with your data in it, hopefully
    Application.ScreenUpdating = True
End Sub

As I said, funny one, I haven't changed anything, but the code should be ok now.

 

[Aydan]

Yeah, the red line is gone, and I cant belive my eyes when the data is being copied to the new sheet so I'm already very happy, allthough there is a (small) problem. At the end of the prices in columC (I have extented the code to include varprice10 because there are 10 purchases per card, also my fault I forgot the address field after the firstname, this is because I have a heavy cold i guess) there is a total (sum of the 10 purchases) which is NOT to be transfered. When I commented the function FindSubsequentContacts everthing(the first contacts) is filled in perfect. But when runnin the code with the FindSubsequentContacts function I see that the total is being transfered. I think that this is causing the shiftings. On the second line it goes wrong starting with a null value for Lastname and in the second cell (firsname) it puts back the address of the firstline and postcode of the firstline in the Adress column. Note that not always are the prices fully entered, some customers did only 1 purchase others 6 or 8..
A great 'Thank you' for the extreemly quickly delivery of code. Now I understand why your name contains the word Power
May be I can try to understand a bit better your code and try to fix it my self(?), could you tell me what this is doing in the functions findfirstcontact and findsubsequentcontact:
'strCellRef = ActiveWindow.RangeSelection.Address'

 

[Aydan]

Bill, I also noticed that the macro takes the contact informtation over until it finds an empthy card (this is at the end of the first colum of the first worksheet), then it only puts a 0 for all the rest of the contacts in the last colum of the new sheet labeled with price10.
In the workbook the cards are not filled in colum by colum. Also not row per row. First there were 2 cards near each other, then we created a third one since it was fitting on one screen but the last added colum is not filled in yet in all worksheets meaning that at the end of a worksheet and in the range J - L there are empthy cards.

 

[BillPower]

Hi Aydan,

Can you e-mail an example of your workbook to me at billpower@cwcom.net , if your work is confidential, send me one sheet with dummy info in it. It will be quicker to update the address field in the code and see what's gone wrong with range J-L.

strCellRef = ActiveWindow.RangeSelection.Address is the variable setup so that the program doesn't go into an infinite loop. On each sheet strCellRef remembers the address of the 1st contact it finds. strCurrCellRef gets the address of all further contacts e.g. my code is:

If strCellRef <> strCurrCellRef Then

The above tells the procedure to continue if the two adresses are different, otherwise we're at the first contact again, exit the loop.

 

[BillPower]

Hi Aydan, Thanks for the e-mail.

What's happened is that when you've translated into Dutch, the procedure was looking for each occurrence of Naam, in Naam: and Voornaam:.

What you need to do is to add a colon to Naam and change xlPart to xlWhole as highlighted below in red. You need to do this in both FindFirstContact() and FindSubsequentContacts(). You should end up with 597 records in your new sheet.

Cells.Find(What:=&quot;Naam:&quot;, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False).Activate

Have a great holiday.

Bill

 

[Aydan]

Hi Bill,
I&quot;ve received a notification for this tread on 24/12, but don't see it in here. May be it's an error.
Greetings from Antwerp!
Aydan

 

[Aydan]

Yes, now I see your answer, what a stupid thing to oversee!! Everything works fine now, you've saved me lots of typing and most important, I learned something about excel's object model. Not that I have more cases like these, but it's always a good thing to have had these experience. Thank you so very much!
Aydan