Free Microsoft Excel 2013
Quick Reference
Free Microsoft 2013 Quick Reference Guide

Free Microsoft Excel 2013 Quick Reference

Cstr function

hi everybody
i am trying to convert a range of numbers to text
using the Cstr function ,it doesnt work.
excel VBA help states that CStr function converts a numeric value to a String.
i am aware that i can convert a number by preceding it with an apostrophe
i just need to know why Cstr doesnt do the job


	VB:
	
 covrt() 
    For Each rng In Selection.Cells 
        rng = CStr(rng.Value) 
    Next 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
thanx in advance


Post your answer or comment

comments powered by Disqus
Hi guys

Does anyone have any clue of a VBA function that gets a cell and Changes the type of it´s contense?

I have been using the Cstr function as in the next example but I dont get the result I want

	VB:
	
(hojaRES.Cells(i, 6)) 
If IsNumeric(hojaRES.Cells(i, 6)) Then 
    MsgBox "nothin changes :(" 
    Exit For 
End If 
hojaRES.Cells(i, 6) = "0" & "34" & hojaRES.Cells(i, 6) 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
My problem is that i want to add 034 prefix to a telephone number, and as it treats the data as numeric; number 0 (before34) is deprecated

Use the CStr function.

--
Cordially,
Chip Pearson
Microsoft MVP - Excel
www.cpearson.com wrote in message
...
> Is there a way to cast or coerce a Variant to String (to avoid the type
> mismatch when passing a Variant where a String is expected)?
> Thanks in advance.
> --
> ThatFella

I have the following code:

If metric_name = Metric_Name_Indexing Then

indexing_total_row = input_wrksht.Cells(Rows.Count, stdy_col_number).End(xlUp).Row

If CStr(input_wrksht.Cells(indexing_total_row, stdy_col_number).Value) <> "Total" Then

err_msg_1 = Application.InputBox( _
    Prompt:="The input file checking procedure has detected what could possibly be an error with input file.  The word
""Total"" was not be found. Do you wish to ignore this and continue with running the program or do you
wish to end the program now?  (C)ontinue or (E)nd")
        
        If err_msg_1 <> "c" And err_msg_1 <> "C" Then
            chkFile_error = True
            GoTo end_chk_inputfile
        End If
End If


When i run this code i get a type mismatch error because the last row is a number. So i thought i would fix the type mismatch erro by using the cstr function in vba to convert item to a string. But i still get a type mismatch error............anythoughts?

Or suggestions on how to test for this?

I have an add-in to excel that I have referenced in a formula. The add-in
retrieves a value from a database. When a value is not found, it displays
'No events found.' In an IF THEN ELSE statement, I'm checking for 'No events
found.', but when the cell meets that criteria it is not matching and just
goes to the 'Error' part of my Else statement (see below). My guess is that
my statement is retrieving the formula in the cell, and not the formula's
results. If I do a MSGBOX, I get the results and not the formula. Any
thoughts?

If (IsNumeric(Worksheets("Data").Range("A7").Value)) Then
MsgBox Worksheets("Data").Range("A7").Value 'show the value
ElseIf CStr(Worksheets("Data").Range("A7").Value) = "No events found."
Then
MsgBox "No events found."
Else
MsgBox "Error"
End If

I've tried it with and without the CStr function to see if it was a format
conversion issue to no avail.

Thanks

I have the following code to populate a ComboBox in User form with a unique list of dates, where the CDate function does not seem to work. I have also used the CLng function but that does not seem to work either. The routine works fine if I have a list of Names using the CStr function.

Can someone offer me a solution please

Private Sub UserForm_Initialize()
Dim Found As Long, i As Long
Dim cel As Range

'Create date List
MyList = "valEndDate" ' This is a list of Dates

Set DataList = Range(MyList)
ReDim FArray(DataList.Cells.Count)
i = -1

For Each cel In DataList
On Error Resume Next
Found = Application.WorksheetFunction.Match(CDate(cel), FArray, 0)
If Found > 0 Then GoTo Exists
i = i + 1
FArray(i) = cel
Exists:
Found = 0
Next
ReDim Preserve FArray(i)
Call BubbleSort(FArray)
ComboBox1.ListRows = i + 1
ComboBox1.List() = FArray
End Sub

Many thanks for assistance/sglxl

Hello,

I have adapted a function I found on google to add unique dates to a collection. The function works, however there is a discrepency between the dates in the spreadsheet and the dates added to the collection. Here is the function;

	VB:
	
 Collection 
     
    Dim DataRange As Variant, Irow As Long, Icol As Integer, MaxRows As Long 
     
    Dim MyVar As Date, lngLoc As Variant 
     
    Dim getDates_ As New Collection 
     
     'On Error Resume Next
    DataRange = Range(myCol & "1").CurrentRegion 
    Icol = 1 
    MaxRows = Range(myCol & "1").CurrentRegion.Rows.Count 
    For Irow = 2 To MaxRows ' start on row 2 as we always have headers
        MyVar = DataRange(Irow, Icol) 
        If IsDate(MyVar) = True Then ' make sure its a date
            getDates_.Add MyVar, CStr(MyVar) ' only add unique values
        End If 
    Next Irow 
    Set getDates = getDates_ 
    Set getDates_ = Nothing 
     
End Function 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
The date in the first cell is 31/01/2011. However


	VB:
	
MyVar = DataRange(Irow, Icol) 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
returns 15/09/2194. Can anyone see what I am doing wrong? Thanks,

Luke

I'm embarrassed to ask this question, but I want to call a function that returns a value, and I don't know how to do that.

Here's my function:

	VB:
	
 TruncateValue(x, intDP) 
    x = CDbl(Left(CStr(x), InStr(1, CStr(x), ".") + intDP)) 
End Function 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
But my plan is to "spit out" x from that function. So if in my userform I run

	VB:
	
.cells(1,1).value = TruncateValue(3.14,1) 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
then A1 would be 3.1

i I have a form contains these 4 text boxes .
1- SendDate: DATE
2- SendFrom: The location A
3- SendTo: Location B
4- Article: Article Number
Those text boxes are bound to the table Send_Detail (Send_Date as date ,SendFrom as string ,SendTo as string ,Article as number,qty,...)
Those first 4 field of the Send_Detail table are primary key .
Send_Detail(SendDate,SendFrom,SendTo,Article,qty,....)
I don't want to send the same article to the same Location at the same day.

And every time that i try to close the form without filling all these 4 text boxes . I got this message "That the primary key shouldn't be null" .
That's true if we want to save things but what if we open the form by mistake and we decided to close it. we cant close it unless we fill all the primary key fields . And after that all these data that we enter in those 4 fields will automatically be saved in the SendDetails table.
what if i made a mistake and i don't want to save the record and i want to cancel the entered and i press on cancel button ... but how can i do that?
1- How can we add a button to cancel the operation (and to not save it at all in the SendDetails table)
2- I tried to do a function that checks if the article exists in the SendDetails table with the same sendFrom , sendTo and sendDate.
But it's not working everytime that i tried to send new article to a Location A , it keep telling the same thing that " You have already sent this article today From the Location A to the Location B" . Even tho If it's not in the table it keeps telling me that it exist.
I think it's because of the 4 text boxes are bound to the SendDetails table, and the all the information that we just entered had inserted to the SendDetails table before entering to the function code.
I hope that some one will help me with this
How can i fix this??
This the the function code:

	VB:
	
 
    Dim db As DAO.Database 
    Dim rs As DAO.Recordset 
    Dim intResult As Integer 
    Dim strSql As String 
     
    Set db = CurrentDb 
     
    strSql = " SELECT Count(*) AS RecordCount" _ 
    & " FROM Send_Details " _ 
    & "where send_Date=#" & d & "#" & " and SendFrom= '" & From & "' " _ 
    & "  and SendTo='" & SendTo & "' " & "  and article=" & id 
    MsgBox strSql 
     
    Set rs = db.OpenRecordset(strSql, dbOpenSnapshot) 
     
    intResult = rs("RecordCount") 
     
    rs.Close 
    db.Close 
    If intResult > 0 Then 
        CheckIfSent1 = True 
    Else 
        CheckIfSent1 = False 
    End If 
End Function 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
And here is the After_Update event that i wrote on the Article

	VB:
	
 
Private Sub Article_AfterUpdate() 
     'if the article has already been sent to the same Location at the same date, send an error message
    If (CheckIfSent(CLng(Forms![transfer]!article), CDate(Forms![transfer]!send_Date), CStr(Forms![transfer]!From),
CStr(Forms![transfer]!To))) Then 
        MsgBox "you have sent this article before" 
        article.SetFocus 
    Else 
         'If the article have not been sent before then set the focus on the quantity of the subform
        [from relax To solderie]!Qty.SetFocus 
    End If 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


Below is the function Syntax required in excel cell to type:

	VB:
	
) 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Function Details:

	VB:
	
=DoMerge(TargetRange,Separator,RemoveDuplicates,KeepBoundarySeparator) 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Here apart from TargetRange, other variables are optional.
Function works perfect if TargetRange is: A1:A10 (i.e A1 to A10)
but fails to qualify if TargetRange is: A1,A3,A5 (i.e. A1 & A3 & A5)

Below is the function Code:

	VB:
	
 = Empty, _ 
    Optional NoDup As Boolean, Optional NoBndSep As Boolean) 
     
    Dim Ce, Mrg As New Collection, NewMrg As String, iCity 
    NewMrg = Empty 
     
    On Error Resume Next 
    For Each Ce In Target 
        If Not IsEmpty(Ce.Value) Then 
            If NoDup = True Then _ 
            Mrg.Add Ce.Value & Sep, CStr(Ce.Value) Else _ 
            Mrg.Add Ce.Value & Sep 
        End If 
    Next Ce 
    On Error Goto 0 
    For Each iCity In Mrg 
        NewMrg = NewMrg & iCity 
    Next iCity 
    Set Mrg = Nothing 
     
    If NoBndSep = True Then 
        If Not IsEmpty(Sep) Then NewMrg = Sep & NewMrg 
    Else 
        If Not IsEmpty(Sep) Then NewMrg = Left(NewMrg, Len(NewMrg) - Len(Sep)) 
    End If 
    DoMerge = NewMrg 
End Function 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
ilyaskazi

Hello,

I have written a program that, amongst other things, assigns index numbers to a list of inputs.
At various points in the program I need to call these inputs by the index number to either store, change, or update the information.
Everything seems to work just fine except for any index numbers that are multiples of 1000, at which point it get the error on the Find Function: Run-time error '91': Object variable or With block variable not set.My find function is straightforward and works for all index values from 1 to 999, 1001 to 1999, 2001 etc...

	VB:
	
(idx), _ 
LookIn:=xlValues, _ 
LookAt:=xlWhole, _ 
searchOrder:=xlByRows, _ 
SearchDirection:=xlNext, _ 
MatchCase:=False).Row 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
where xExc is the sheet with the values and idx is the index number
When I debug I don't find any exceptions; idx is still being put in as 1000, and when I manually change the index number in the sheet it does not choke.

Has anybody run into a similar error? It's quite annoying and I would prefer to fix it rather than skip a number every 1000 entries.

Thanks for your help!

Hi I have a form contains these 4 text boxes .
1- send_Date: DATE
2- SendFrom: The location A
3- SendTo: Location B
4- Article: Article Number
Those text boxes are bound to the table Send_Date(send_Date as date ,SendFrom as string ,SendTo as string ,Article as number,qty,...)
I don't want to send the same article to the same Location at the same day.

I wrote this function

	VB:
	
 
Public Function CheckIfSent(ByRef id As Long, ByRef d As Date, ByRef From As String, ByRef SendTo As String) As Boolean 
     
    Dim db As DAO.Database 
    Dim rs As DAO.Recordset 
    Dim intResult As Integer 
    Dim strSQL As String 
     
    Set db = CurrentDb 
     
    strSQL = " SELECT Count(*) AS RecordCount" _ 
    & " FROM Send_Details " _ 
    & "where send_Date=#" & CStr(d) & "#" & " and SendFrom= '" & From & "' " _ 
    & "  and SendTo='" & SendTo & "' " & "  and Article=" & id 
    MsgBox strSQL 
    Set rs = db.OpenRecordset(strSQL, dbOpenSnapshot) 
     
    rs.MoveLast 
    intResult = rs("RecordCount") 
     
    MsgBox intResult 
     
    rs.Close 
    db.Close 
    If intResult > 0 Then 
        CheckIfSent = True 
    Else 
        CheckIfSent = False 
    End If 
    MsgBox CheckIfSent 
     
End Function 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
And here where i'm calling the function

	VB:
	
 
Private Sub Article_AfterUpdate() 
     
    If (CheckIfSent(CLng(Forms![Transfer]!Article), CDate(Forms![Transfer]!send_Date), CStr(Forms![Transfer]!SendFrom),
CStr(Forms![Transfer]!SendTo))) Then 
        MsgBox "you have sent this article before" 
        Article.SetFocus 
    Else 
         ' do another stuff
        DoCmd.DoMenuItem acFormBar, acRecordsMenu, 5, , acMenuVer70 
    End If 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
the problem is that even if the article have been sent before from a location to another that have been selected at the same date ... it gives the number 0 and false ... and don't go threw the msgbox that's mean that i don't get the "you have sent this article before" ... it will enter into the else .... could anyone know why ? and what's i'm doing wrong ?

I have this spreadsheet with tons of vba coding. The intent of the spreadsheet is to track invoices as it goes through the approval process. The part that is giving me issues is the first and seventh column. The seventh column is actually a formula that returns how many days between the invoice due date and today’s date. The coding works fine, with one small glitch. Once the dates have been entered, the first column (which contains the color-coding) stops changing colors. What it should do is anything with 0 or less days remaining should show red, between 1 to 10 days, show yellow and anything above 10 days, show green.

So if I enter an invoice with 11 days remaining to pay, it will show green in the first column, but when I open the spreadsheet tomorrow, it remains green, even though it should show yellow.
What I want it to do is refresh every time it is opened, or every day, which ever is easier. There are reasons that we cannot use conditional formatting, one of them being that we want to expand the color coding system to more than 3 colors soon, but I want to get this working correctly first.

This is what I have. I cannot attach the spreadsheet because it contains confidential information.

Any help is appreciated. Thanks!


	VB:
	
 Range) 
     
    Dim h As Integer 
    Dim i As Integer 
    Dim j As Integer 
    Dim lastRow As String 
    Dim fRowValue As String 
    Dim gRowValue As String 
    Dim mRowValue As String 
    Dim rRowValue As String 
    Dim uRowValue As String 
    Dim paidCheck As String 
    Dim stringAnswer As String 
    Dim testAnswer As String 
    Dim testDate As String 
     
    Application.ScreenUpdating = False 
     
    lastRow = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row 
     
    For j = 8 To lastRow 
        If Not Intersect(Cells(j, 2), Target) Is Nothing Then 
            fillCodes (j) 
        End If 
         
        If Not Intersect(Cells(j, 4), Target) Is Nothing _ 
        Or Not Intersect(Cells(j, 5), Target) Is Nothing _ 
        Or Not Intersect(Cells(j, 6), Target) Is Nothing _ 
        Or Not Intersect(Cells(j, 7), Target) Is Nothing _ 
        Then 
             
            stringanswer1 = CStr(Cells(j, 20).Value) 
            stringAnswer = CStr(Cells(j, 7).Value) 
             
            For i = 8 To lastRow 
                If IsDate(stringasnwer1) Then 
                    Cells(j, 1).Interior.ColorIndex = 1 
                Else 
                     
                    If IsNumeric(stringAnswer) Then 'stringAnswer  "Paid" Then
                        Cells(j, 1) = colorCode(stringAnswer, j) 
                    End If 
                End If 
            Next 
        End If 
        If Not Intersect(Cells(j, 20), Target) Is Nothing Then 
            testAnswer = Cells(j, 20).Value 
            stringAnswer = Cells(j, 7).Value 
             
            If IsDate(testAnswer) Then 
                Cells(j, 1).Interior.ColorIndex = 1 
            Else 
                Cells(j, 1) = colorCode(stringAnswer, j) 
            End If 
        End If 
    Next 
     
    Sheets("Control Box").Visible = xlHidden 
    Application.ScreenUpdating = True 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
And there are 2 modules. I only broke my functions out of easy of reading. Not sure if you need both, but thought it might be safer to include everything.

	VB:
	
 
    fRowValue = "=IF(isnumber(E" & j & ")=False," & """""" & ",if(and(D" & j & "=" & """""" & ",E" & j & "=" & """""" & "),"
& """""" & ",date(year(D" & j & "),month(D" & j & "),day(D" & j & ")+E" & j & ")))" 
    Cells(j, 6).Value = fRowValue 
     
    gRowValue = "=IF(E" & j & "=" & """""" & "," & """""" & ",if(T" & j & "" & """""" & "," & """Paid""" & ",if(F" & j & "="
& """""" & "," & """""" & ",date(year(f" & j & "),month(f" & j & "),day(f" & j &
"))-date(year($d$4),Month($d$4),day($d$4)))))" 
    Cells(j, 7).Value = gRowValue 
     
    mRowValue = "=IF(and(L" & j & "=0,S" & j & "=" & """""" & "),0,if(and(L" & j & "=0,s" & j & "" & """""" & "),K" & j &
",sum(K" & j & "-L" & j & ")))" 
    Cells(j, 13).Value = mRowValue 
     
    rRowValue = "=if(Q" & j & "=" & """""" & "," & """""" & ",DATE(YEAR(Q" & j & "),MONTH(Q" & j & "),DAY(Q" & j &
"))-DATE(YEAR(D" & j & "),MONTH(D" & j & "),DAY(D" & j & ")))" 
    Cells(j, 18).Value = rRowValue 
     
    uRowValue = "=if(T" & j & "=" & """""" & "," & """""" & ",IF(Q" & j & "=" & """""" & "," & """""" & ",DATE(YEAR(T" & j &
"),MONTH(T" & j & "),DAY(T" & j & "))-DATE(YEAR(Q" & j & "),MONTH(Q" & j & "),DAY(Q" & j & "))))" 
    Cells(j, 21).Value = uRowValue 
    End 
End Function 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines

	VB:
	
) 
     '    Cells(i, 1).Interior.ColorIndex = xlColorIndexNone
    Select Case stringAnswer 
    Case Is

Hello All,

I've been supplied with a function that can help me through a friend.


	VB:
	
 
    Dim cl As Range, UniqueValues As New Collection 
    InputRange.AdvancedFilter Action:=xlFilterInPlace, Unique:=True 
    For Each cl In InputRange 
        If Not cl.Entirerow.Hidden Then 
            UniqueValues.Add cl.Value, CStr(cl.Value) ' add the unique item
        Next cl 
        On Error Goto 0 
        CountUniqueValues = UniqueValues.Count 
    End Function 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Right now, the function does not work but the layout is correct. I was wondering if any expert programmers can reorganize the layout for me? It's supposed to create an array of all the unique values. Any duplicates are not added to this array and at the end, a count of this array is provided. It does not work after I added the If statement there but I need that condition as I want to count the number of unique entries within a filter. Hence, if there are hidden lines, this function would calculate the total number of unique entries only visible at that time. Perhaps this method of creating an array is not feasible; are there any suggestions? I think the approach is somewhat working but I need an alternative to simply making another array. Thanks alot.

Hello,

I've a tricky problem. I'd like to use database functions such as DCount, DSum or DAverage in VBA for Excel.

My makro runs in a different workbook as the data is stored in. But both worksheets used in my VBA code are part of the data workbook (strExcelFile).

In worksheet(1) of the data workbook a large database containing a lot of columns and cases (rows) are included. One column builds four groups to which each case is assigned. In another column a price indicator for each case is given.

Another function (FT_Generate_Criteria(Excel file name, start row for criteria table, index number of criteria worksheet, array of criterias) builds a second worksheet in this data workbook and prepares it with criteria required for the database functions.
For instance it generates in worksheet(2) a table such as

column 1 / column 2
row 1 / criteria column 1 name / criteria column 2 name
row 2 / criteria column 1 precondition / criteria column 2 precodition

This necessary table is also described in the MS Excel help for database functions.

Moreover, this function returns the range in which the criterias are written in Worksheet(2).

Now, to give you an example of my code:


	VB:
	
 
Dim strGroupColumn As String 
Dim strPriceColumn As String 
 
Dim intWorksheet As Integer 
Dim intMaxZeile As Integer 
Dim intPriceColumn As Integer 
Dim intGroupColumn As Integer 
Dim intGroupNumber As Integer 
 
Dim arrCriteria() As Variant 
 
Dim dblMaxUmsatz As Double 
Dim dblBasePrice As Double 
 
Dim rngDataSearchRange As Range 
Dim rngDataBaseRange As Range 
 
strExcelFile = "Sample.xls" 
intPriceColumn = 2 
intGroupColumn = 3 
intGroupNumber = 1 
intMaxZeile = 393 
arrBasePrice = Array(24.5, 24.12, 22.3, 21.5) 
intWorksheet = 1 
 
With Workbooks(strExcelFile) 
     
     'defines database as range for further use
    Set rngDataBaseRange = .Worksheets(intWorksheet).Range(.Worksheets(intWorksheet).Cells(1, intPriceColumn),
.Worksheets(intWorksheet).Cells(intMaxZeile, intGroupColumn)) 
     
     'reads some necessary column names as strings from database
    strPriceColumn = CStr(.Worksheets(intWorksheet).Cells(1, intPriceColumn).Value) 
    strGroupColumn = CStr(.Worksheets(intWorksheet).Cells(1, intGroupColumn).Value) 
     
     'takes base price assigned to the group from price array
    dblBasePrice = CDbl(arrBasePrice(intGroupNumber - 1)) 
     
     'build array with criteria used in function FT_Generate_Criteria
    Redim Preserve arrCriteria(2, 2) 
    arrCriteria(0, 0) = strGroupColumn 'criteria 1 name
    arrCriteria(1, 0) = intGroupNumber ' criteria 1 precondition
    arrCriteria(0, 1) = strPriceColumn ' criteria 2 name
    arrCriteria(1, 1) = "" 'criteria 2 precondition - is here empty
    Set rngDataSearchRange = FT_Generate_Criteria(strExcelFile, -2, 3, arrCriteria) 
     
     'as long as I use only one precondition in one criteria the code below does work realy great
    dblMaxUmsatz = Application.WorksheetFunction.DSum([rngDataBaseRange], strPriceColumn, [rngDataSearchRange]) 
     
     'now I introduce a precondition for criteria 2 and rebuild the criteria table
    arrCriteria(1, 1) = ">" & dblBasePrice 'criteria 2 precondition
    Set rngDataSearchRange = FT_Generate_Criteria(strExcelFile, -2, 3, arrCriteria) 
     
     ' AND now the code does not work an returns "0"
    intBuyer = Application.WorksheetFunction.DCount([rngDataBaseRange], strPriceColumn, [rngDataSearchRange]) 
     
End With 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
However, I though maybe it has some problems with the second precondition, but no! I used the Worksheet.function directly in Worksheet(2): DCount(table1!A1:FD393;Criteria!B3;Criteria!A3:B4) and it worked great with completly the same database matrix and criteria matrix used in the VBA code. For instance, it returns a value of '60' for the preconditions used in the VBA Code.

What I am I doing wrong? Is there a know error by using database function as worksheets.functions in VBA code? What can I do to make it work?

I really grateful for any suggestions regarding this topic.

Cheers,
Maik

I had been using Harlan Grove's PULL function in order to link to data in another workbook that wasn't necessarily currently
open in Excel.

The PULL function allows you to specify the details of your linked range as a cell value (unlike a direct link), similar to the
INDIRECT function. However, INDIRECT doesn't work with closed workbooks. I like Harlan's PULL function because the code is
open and can be easily copied and pasted into additional VBA workbooks as required so that no add-ins are needed. (I have not
had much experience with using INDIRECT.EXT via the MoreFunc add-in, although it is possible to "attach" MoreFunc to a workbook
so that functions can be used without the add-in being installed.)

The PULL function works well - however, it can be slow to use when returning large ranges of cells. For example, we had a
spreadsheet that was taking 5 minutes to update when using PULL to refer to a range of 3000 cells. So I looked into creating
an alternative function that would be more suited to my circumstance. I feel I was successful and wanted to share my findings
here, since the publishing of the PULL function was very helpful to me. (Harlan - I hope that you don't mind that I have used
some of your ideas in the new function.)

The PULL function uses the ExecuteExcel4Macro command to get values from a cell from a closed workbook. The LINKEDRANGE
function that I present here differs from PULL in that it actually opens the linked workbook (in a separate Excel instance,
since spreadsheets cannot be normally be opened in a UDF), gets the values it needs and closes the workbook.

LINKEDRANGE may be faster than PULL when returning ranges of values from linked workbooks. LINKEDRANGE may be slower than PULL
when returning single values or small ranges.

Furthermore, LINKEDRANGE can be used to link to named ranges that refer to a range of more than one cell. (PULL works with
named ranges that refer to a single-cell only.)

The VBA code and sample spreadsheets are located he
http://www3.sympatico.ca/sstackho/LinkedRange.zip

The .bas file can be used for easy importing into spreadsheets.

Although I have tested the code on a couple of machines, it certainly will not be as bulletproof as the PULL function. Harlan
has added several layers of armor to the PULL function over the years so that it works on more Excel versions and more
operating systems. Since I don't fully understand all of the error-checking logic in the PULL function, I wasn't comfortable
adding it to the LINKEDRANGE function. Harlan or anybody: please feel free to make this function better by adding any
additional logic as you see fit.

I will paste the code below, although it might not look very good with line-wrapping, etc. The code is also available at the
link above.

'-------------------------------------------------
'-------------------------------------------------

Option Explicit

Function LINKEDRANGE(Link As String) As Variant

' Developed by Shawn Stackhouse
' Inspired (and partially developed) by Harlan Grove and his PULL function
' that was in turn inspired by Bob Phillips and Laurent Longre
'-----------------------------------------------------------------
'This code is free software; you can redistribute it and/or modify
'it under the terms of the GNU General Public License as published
'by the Free Software Foundation; either version 2 of the License,
'or (at your option) any later version.
'-----------------------------------------------------------------

' Version History
'
' v1 - 2006-08-24
' v1.1 - 2006-08-25
' - changed structure to have the function accept a single input and split out the LINKREFERENCE logic to a separate
function
' - fixed problem with conflict between workbook-level and worksheet-level named ranges

' Purpose:
' This user-defined function can be used to get values from another spreadsheet, even if it is not open.
'
' This provides similar functionality to using regular Excel links, but allows the locations and names of
' linked workbooks to be specified via cells.
'
' LINKEDRANGE provides similar functionality to Harlan Grove's PULL function.
'
' LINKEDRANGE differs from Harlan Grove's PULL function in that LINKEDRANGE actually opens the linked workbook (in a
' separate Excel instance, since spreadsheets cannot be normally be opened in a UDF) to get the linked values.
' Furthermore, LINKEDRANGE can be used to link to named ranges that refer to more than one cell.
'
' LINKEDRANGE may be faster than PULL when returning ranges of values from linked workbooks. LINKEDRANGE may
' be slower than PULL when returning single values or small ranges.

' **** NOTE ****
' This function requires a full recalculation (Ctrl+Alt+F9) in order to update values

' Function Output:
' - a range of variable size
' - to return a range of cells, use LINKEDRANGE as a formula array (Ctrl+Shift+Enter)

Dim xlapp As Object, xlwb As Workbook, xlws As Worksheet
Dim r As Range, iChrPos As Long
Dim Directory As String, WorkbookName As String, WorksheetName As String, WorksheetRange As String
Dim NamedRangeRefersTo As String

On Error GoTo CleanUp

' Check to see if the referenced range is currently open in this Excel instance,
' by using an Evaluate function. If the function returns an error, then the
' range is not open (or the range is invalid).

' Do an EVALUATE on Link to see if the referenced range is currently open in this Excel instance.
' The Evaluate function will return an error if the range is not open
LINKEDRANGE = Evaluate(Link)

' If the range is not open (or invalid), an error will be returned from the above statement and
' the following section will be processed

If CStr(LINKEDRANGE) = CStr(CVErr(xlErrRef)) Then

' Let's decipher the Directory, WorkbookName, WorksheetName and WorksheetRange from the Link string.
' The Link string can be in a variety of formats.

' If the first character is not a single quote, then a Directory has not been defined.
If Left(Link, 1) "'" Then
Exit Function
End If

' Remove the leading single quote
Link = Mid(Link, 2, Len(Link) - 1)

' the Directory name will end at the last occurrence of ""
' find last occurrence of ""
iChrPos = InStrRev(Link, "")
Directory = Left(Link, iChrPos)
Link = Mid(Link, iChrPos + 1, Len(Link) - iChrPos)

' The next character will be a "[" unless the worksheet name has not been defined (and a workbook-level named range is
being used)
If Left(Link, 1) = "[" Then

' a worksheet is defined, the Workbook name will be until "]"
iChrPos = InStr(Link, "]")
WorkbookName = Mid(Link, 2, iChrPos - 2)
Link = Mid(Link, iChrPos + 1, Len(Link) - iChrPos)

' the worksheet name will be until a single quote
iChrPos = InStr(Link, "'")
WorksheetName = Mid(Link, 1, iChrPos - 1)
Link = Mid(Link, iChrPos + 2, Len(Link) - iChrPos)

Else

' a worksheet is not defined
WorksheetName = ""

' the workbook name will be until a single quote
iChrPos = InStr(Link, "'")
WorkbookName = Mid(Link, 1, iChrPos - 1)
Link = Mid(Link, iChrPos + 2, Len(Link) - iChrPos)

End If

' the WorksheetRange will be what is left over in the Link string
WorksheetRange = Link

' Create a new Excel instance
Set xlapp = CreateObject("Excel.Application")

' Open the linked workbook as read-only and do not update any links in the linked workbook.
' If the workbook doesn't exist, an error will be triggered.
Set xlwb = xlapp.Workbooks.Open(Directory & WorkbookName, UpdateLinks:=False, ReadOnly:=True)

' If a workbook-level name has been used (i.e. no WorksheetName was specified), then we need to refer
' to the RefersTo property of the named range to ascertain the proper worksheet.
If WorksheetName = "" Then

' temporarily add a blank worksheet to avoid problems with worksheet-level named ranges
Set xlws = xlwb.Worksheets.Add

NamedRangeRefersTo = xlwb.Names(WorksheetRange).RefersTo
' find the '!' in the range
iChrPos = InStr(1, NamedRangeRefersTo, "!")
WorksheetName = Mid(NamedRangeRefersTo, 2, iChrPos - 2)

'check for single quotes around WorksheetName
If Left(WorksheetName, 1) = "'" Then
WorksheetName = Mid(WorksheetName, 2, Len(WorksheetName) - 2)
End If
End If

' Refer to the WorksheetName worksheet.
' If the worksheet doesn't exist, an error will be triggered.
Set xlws = xlwb.Worksheets(WorksheetName)

' Refer to the WorksheetRange range on the worksheet.
' If the range doesn't exist or is invalid, an error will be triggered.
Set r = xlws.Range(WorksheetRange)

LINKEDRANGE = r

End If

CleanUp:
Set xlws = Nothing
If Not xlwb Is Nothing Then xlwb.Close 0
Set xlwb = Nothing
If Not xlapp Is Nothing Then xlapp.Quit
Set xlapp = Nothing

End Function

'-------------------------------------------------
'-------------------------------------------------

' In order to assist with building the 'Link' parameter above (or 'xref' for PULL),
' I created another little UDF below that returns the Link parameter based on
' directory, workbook, worksheet and range inputs.

'-------------------------------------------------
'-------------------------------------------------

Function LINKREFERENCE(Directory As String, WorkbookName As String, WorksheetName As String, WorksheetRange As String) As
String

' This function can used as a helper for the LINKEDRANGE function. This function takes in information about the linked range
' and returns a link reference in the form needed by LINKEDRANGE.

' Function Inputs:
'
' Directory - the full path that contains the workbook from which values will be pulled
' - trailing "" is optional
' - e.g. C:LinkedData
' - relative directories can be used
' - e.g. "C:DummyDirectory..LinkedData" (evaluates to C:LinkedData)
'
' WorkbookName - the name of the workbook from which values will be pulled
' - e.g. LinkedWorkbook.xls
'
' WorksheetName - optional - leave blank if referring to a workbook-level named range
' - the name of the worksheet from which values will be pulled
' - e.g. LinkedSheet
'
' WorksheetRange - the cell range or named range from which values will be pulled
' - e.g. A1:E5
' - e.g. $A$1:$E$5
' - e.g. LinkedNamedRange

' Function Output:
' LINKEDRANGE - a string that contains the link reference in the form used by LINKEDRANGE

Dim sLinkReference As String

On Error GoTo CleanUp

' If the Directory, WorkbookName or WorksheetRange fields are not defined, then exit the function immediately.
If IsEmpty(Directory) Or IsEmpty(WorkbookName) Or IsEmpty(WorksheetRange) Then
Exit Function
End If

' Trim the inputs of any excess spaces
Directory = Trim(Directory)
WorkbookName = Trim(WorkbookName)
WorksheetName = Trim(WorksheetName)
WorksheetRange = Trim(WorksheetRange)

' check the Directory string and append a '' to its end if it doesn't already have one
If Right(Directory, 1) "" Then
Directory = Directory & ""
End If

' prefix with a single quote
sLinkReference = "'" & Directory ' e.g. 'C:LinkedData

' A worksheet does not need to be specified if using a workbook-level name.
' The format of the 'xref' statement to be evaluated differs if the workbook is not defined.
' Add a "[" if the worksheet name is defined.
If WorksheetName "" Then
sLinkReference = sLinkReference & "[" ' e.g. 'C:LinkedData[
End If

' Add the workbook name
sLinkReference = sLinkReference & WorkbookName ' e.g. 'C:LinkedData[LinkedWorkbook.xls

' Add a "]" if the worksheet name is defined
If WorksheetName "" Then
sLinkReference = sLinkReference & "]" ' e.g. 'C:LinkedData[LinkedWorkbook.xls]
End If

' Add the worksheet name (may be blank)
sLinkReference = sLinkReference & WorksheetName ' e.g. 'C:LinkedData[LinkedWorkbook.xls]LinkedSheet

' Add a single quote and exclamation point
sLinkReference = sLinkReference & "'!" ' e.g. 'C:LinkedData[LinkedWorkbook.xls]LinkedSheet'!

' Add the linked range (cell range or named range)
sLinkReference = sLinkReference & WorksheetRange ' e.g. 'C:LinkedData[LinkedWorkbook.xls]LinkedSheet'!A1:E5

LINKREFERENCE = sLinkReference

CleanUp:

End Function

'-------------------------------------------------
'-------------------------------------------------

' Finally, here's a small UDF to return the current workbook directory, which can be helpful
' for creating relative links. This is preferable to using the CELL("filename", A1) function
' since CELL("filename") is volatile (even though Microsoft claims it is not!)

'-------------------------------------------------
'-------------------------------------------------

Function ThisWorkbookDirectory() As String
' This function returns the directory of this workbook.

Dim sFullName As String
Dim iChrPos As Integer, iStrPos As Integer

sFullName = ThisWorkbook.FullName

' find last occurrence of ""
iChrPos = InStrRev(sFullName, "")
ThisWorkbookDirectory = Left(sFullName, iChrPos)

End Function

-------------------------------------------------

I hope that someone finds this helpful!

Thanks,
Shawn Stackhouse

--
----------------------------------------------
Posted with NewsLeecher v3.0 Final
* Binary Usenet Leeching Made Easy
* http://www.newsleecher.com/?usenet
----------------------------------------------

Hi All
I copied this function from a VBA book and I get a Error 91 "object variable or with Block variable not set"

I have made sure that Microsoft scripting is referenced.
any clues would be appreciated.
I might add that this is a follow up on a thread I discussed with "Datasmart", thanks to John for getting me started.

{code]
Function BrowseForfolderShell() As String
Dim objshell As Object, objfolder As Object
Set obshell = CreateObject("Shell.Application")
'Uncomment next line to start at desktop
'Set objfolder = objshell.BrowseForFolder(0, "Please Select a Folder", 0, 0)
Set objfolder = objshell.BrowseForFolder(0, "Please select a Folder", 0, "c:")
If (Not objfolder Is Nothing) Then
On Error Resume Next
If IsError(objfolder.items.Item.Path) Then BrowseForfolderShell = _
CStr(objfolder): GoTo here
On Error GoTo 0
If Len(objfolder.items.Item.Path) > 3 Then
BrowseForfolderShell = objfolder.items.Item.Path & _
Application.PathSeparator
Else
BrowseForfolderShell = objfolder.items.Item.Path
End If
Else: Application.ScreenUpdating = True: End
End If
here:
Set objfolder = Nothing: Set objshell = Nothing

End Function
{code]

Regards
Michael M

Hello everyone!

I'm now using Excel 2007.

I have a file with some sheets. In one of the sheets I have the
following code:

Sub CSO()
' CSO Macro
' ordenar colaboradores por ranking
'
' Keyboard Shortcut: Ctrl+o
'

ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("R9:R40"), _
SortOn:=xlSortOnValues, Order:=xlAscending,
DataOption:=xlSortNormal
With ActiveWorkbook.ActiveSheet.Sort
.SetRange Range("B9:AA40")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

bons = ActiveWorkbook.ActiveSheet.Range("AL12")
medios = ActiveWorkbook.ActiveSheet.Range("AL10")
maus = ActiveWorkbook.ActiveSheet.Range("AL9")

celinicio = 9
celula = "AG" + CStr(celinicio)
celulanome = "B" + CStr(celinicio)
'contador = bons
Total = bons + medios + maus

For i = 1 To Total
If bons > 0 Then
celula = "AE" + CStr(celinicio)
ActiveWorkbook.ActiveSheet.Range(celula) =
ActiveWorkbook.ActiveSheet.Range(celulanome)
bons = bons - 1
ElseIf medios > 0 Then
celula = "AD" + CStr(celinicio)
ActiveWorkbook.ActiveSheet.Range(celula) =
ActiveWorkbook.ActiveSheet.Range(celulanome)
medios = medios - 1
ElseIf maus > 0 Then
celula = "AC" + CStr(celinicio)
ActiveWorkbook.ActiveSheet.Range(celula) =
ActiveWorkbook.ActiveSheet.Range(celulanome)
maus = maus - 1
End If
celinicio = celinicio + 1
celulanome = "B" + CStr(celinicio)

Next i
End Sub

I intend to create a procedure or function (to go to search to help) and
later invoking in each one of sheets this procedure, of form to apply
this code in some sheets.

Please help and thanks in advance!

Hi Lenny,

Here's an example of how this works:

-------------
In Book1.xls
-------------
Public Function MyFunc(ByVal lArg As Long, ByVal szArg As String) As String
MyFunc = "Arguments Passed:" & vbLf & _
"lArg = " & CStr(lArg) & vbLf & _
"szArg = " & szArg
End Function

----------------
In VB6 Project
----------------
''' You must set a reference to the Excel object library to run this.
Sub Main()
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim szResult As String
Set xlApp = New Excel.Application
Set xlBook = xlApp.Workbooks.Open("E:Book1.xls")
szResult = xlApp.Run("Book1.xls!MyFunc", 10, "Some String")
MsgBox szResult
xlBook.Close False
Set xlBook = Nothing
xlApp.Quit
Set xlApp = Nothing
End Sub

--
Rob Bovey, MCSE, MCSD, Excel MVP
Application Professionals
http://www.appspro.com/

* Please post all replies to this newsgroup *
* I delete all unsolicited e-mail responses *

"Leonard Jonas" > wrote in message
...
> I have found a lot of literature online about calling excel 2000 macros
> programmatically from VB6xlApp.Run "Personal.xls!MyMacro", Arg1, Arg2)
> but I haven't been able to find any information about calling FUNCTION
> MACROS which return a value. The above syntax (result =
> xlApp.Run"Personal.xls!MyFunctionMacro", Arg1, Arg2) doesn't work when I
> want to call a function macro and have a value returned to VB.
>
> I also tried to get around this (with no luck) by passing arguments
> ByRef to an Excel macro and updating them within the macro. This works
> when the sub is called from within VBA, but if I'm in VB, the variable
> does not reflect the changes that take place in VBA.
> For example:
> (In Excel -- Personal.xls)
> Sub ChangeX(x ByRef as integer)
> x = 50
> End Sub
> (In VB)
> Sub MyProgram()
> dim x as integer
> x = 0
> xlApp.Run "Personal.xls!ChangeX" x
> MsgBox x 'here x is still 0
> End Sub
>
> If you know how to make either of these techniques work, please let me
> know
>
> Thanks!
> Lenny
>
> *** Sent via Developersdex http://www.developersdex.com ***
> Don't just participate in USENET...get rewarded for it!

Hi

I have a VBA function which is trying to split a string into component parts. Typically the string will be something like "01-000-000"

I have successfully split this using variants of Left and Mid such as:


	VB:
	
(Left(SourceRng.Value, 2)) 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
However when strEntity (in the above example) is then returned as a value in a cell it is showing as "1" rather than "01".

Any ideas how I can retain this format? In Excel I would use TEXT(value,"00") but can't find a VBA equivalent?

I'm using Excel 2007 for info.

Any help much appreciated!

Cheers

Chris

Dear technical wizards,

I desperately seek your guidance. I have a dashboard file (.xls) which references several, template excel files located on our Sharepoint (example: Template1, Template2, etc). Currently, I manually update the links in the Dashboard to each of the Template files. It is a hassle to say the least, and its limiting my ability to hand-over the dashboard to the user group.

I have successfully used Harlan Grove's "PULL" UDF to create a dynamic link to a closed file located on my local computer. However, it does not work with files on the Sharepoint.

Can you please advise if it is possible? If not, may I ask if you can suggest alternatives?

I truly appreciate your help.

Code I am using is below:

Thank you,
J.


	VB:
	
 
 
Function pull(xref As String) As Variant 
     'inspired by Bob Phillips and Laurent Longre
     'but written by Harlan Grove
     '-----------------------------------------------------------------
     'Copyright (c) 2003 Harlan Grove.
     '
     'This code is free software; you can redistribute it and/or modify
     'it under the terms of the GNU General Public License as published
     'by the Free Software Foundation; either version 2 of the License,
     'or (at your option) any later version.
     '-----------------------------------------------------------------
     '2005-05-02
     'fixed InStrRev syntax. Now using XL2K+ syntax.
     '-----------------------------------------------------------------
     '2005-04-18
     'added logic to check for date values from open workbooks, then
     'adjust for 1904 date system in source workbooks
     '-----------------------------------------------------------------
     '2004-05-30
     'still more fixes, this time to address apparent differences between
     'XL8/97 and later versions. Specifically, fixed the InStrRev call,
     'which is fubar in later versions and was using my own hacked version
     'under XL8/97 which was using the wrong argument syntax. Also either
     'XL8/97 didn't choke on CStr(pull) called when pull referred to an
     'array while later versions do, or I never tested the 2004-03-25 fix
     'against multiple cell references.
     '-----------------------------------------------------------------
     '2004-05-28
     'fixed the previous fix - replaced all instances of 'expr' with
     ''xref' also now checking for initial single quote in xref, and if
     'found advancing past it to get the full pathname [really dumb!]
     '-----------------------------------------------------------------
     '2004-03-25
     'revised to check if filename in xref exists - if it does, proceed;
     'otherwise, return a #REF! error immediately - this avoids Excel
     'displaying dialogs when the referenced file doesn't exist
     '-----------------------------------------------------------------
    Const DS1904DIFF As Long = 1461 
     
    Dim xlapp As Object, xlwb As Workbook 
    Dim b As String, r As Range, c As Range, n As Long, ds1904 As Boolean 
     
     '** begin 2004-05-30 changes **
     '** begin 2004-05-28 changes **
     '** begin 2004-03-25 changes **
     '** 2005-05-02 change - XL2K+ syntax **
    n = InStrRev((xref), "") 
     
    If n > 0 Then 
        If Mid(xref, n, 2) = "[" Then 
            b = Left(xref, n) 
            n = InStr(n + 2, xref, "]") - n - 2 
            If n > 0 Then b = b & Mid(xref, Len(b) + 2, n) 
             
        Else 
             '** 2005-05-02 change - XL2K+ syntax **
            n = InStrRev((xref), "!") 
            If n > 0 Then b = Left(xref, n - 1) 
             
        End If 
         
         '** key 2004-05-28 addition **
        If Left(b, 1) = "'" Then b = Mid(b, 2) 
         
        On Error Resume Next 
        If n > 0 Then If Dir(b) = "" Then n = 0 
        Err.Clear 
        On Error Goto 0 
         
    End If 
     
    If n

Hi! I'm trying to write a piece of code to calculate the gestational age of expectant mothers based on their estimated due date. This is a first attempt at making a user defined function in excel and I can't seem to figure out why it won't work. Any help you can give would be much appreciated.

Thank you!
Laurie

Function GA(edc As Date, dd As Date, today As Date) As String
'Gestational Age (GA)
If IsMissing(today) Then
today = Date
End If
If IsMissing(edc) Then
GA = ""
Else
Select Case dd
Case IsMissing
GA_Days_Total = 280 + Int(edc - today)
Case Is > today
GA_Days_Total = 280 + Int(edc - dd)
Case Is = today
GA_Days_Total = 280 + Int(edc - dd)
End Select

GA_Weeks = Fix(GA_Days_Total / 7)
GA_days = GA_Days_Total Mod 7

GA = CStr(GA_Weeks) & " " & CStr(GA_days) & "/7 weeks"
End If

End Function

I have been using this function:
Public Function DoFind(Rng As Range, ToFind)
    Dim FirstAddress As String
    Dim c As Range
    Set c = Rng.Find(ToFind, LookIn:=xlValues, Lookat:=xlWhole)
    If Not c Is Nothing Then
        FirstAddress = c.Address
        Do
            Rng.Parent.Cells(c.Row, 1).Resize(, 45).Interior.ColorIndex = 43
            Set c = Rng.FindNext(c)
        Loop While Not c Is Nothing And c.Address <> FirstAddress
    End If
End Function
Public Function WorkSheetExists(sWorkSheet As String, Optional sWorkbook As String = "") As Boolean
    Dim WS As Worksheet, wb As Workbook
    On Error GoTo notExists
    If sWorkbook = "" Then
        Set wb = ActiveWorkbook
    Else
        Set wb = Workbooks(sWorkbook)
    End If
    Set WS = wb.Worksheets(sWorkSheet)
    WorkSheetExists = True
    Exit Function
notExists:
    WorkSheetExists = False
End Function
Which is called from here:
Public Sub Highlight_Items_In_Array()
    Dim c As Range
    Dim Rng As Range
    Dim txt As Variant
    Dim Arr, a

    ArrayTxt = Array("West Chicago Pizza Company", "FireHouse Subs")


     
    Arr = Array("Sheet1", "Sheet2")
     
    For Each a In Arr
        If WorkSheetExists(CStr(a)) Then
            With Worksheets(a)
                Set Rng = .Range(.Cells(2, 1), .Cells(Rows.Count, 45).End(xlUp))
            End With
            For Each txt In ArrayTxt
                DoFind Rng, txt
            Next txt
        End If
    Next a
End Sub

Now this code worked to perfection when the name was in column A now the name has been moved to column B and for the life of me I can't remember which piece needs to be modified to account for the name being moved to column B. can someone refresh this old old memory of mine?

Hello everybody,

I have a problem with calling a DLL, writen in C++, from my Excel
macro.
The function calls work with 90% of all our users but there are two
customers, where the functions are simply not executed. No error occurs
and the function returnvalue is set to 0, meaning OK.
They are both working with different machines, OS and excel versions,
so I don't think it's a version problem.

I made a special diagnosis version, showing messageboxes before and
after the function call and also from the DLL functions.
My customers get the messages from the excel macro but no messages from
the dll. Nevertheless the returnvalue is changed from 5 to 0. There is
no error message at all.

Here is, how I call the function:

Public Declare Function CalcPlanetCoordinates Lib "SemRaumTest4" (v()
As Double, ByRef x As Double, ByRef y As Double, ByVal lpName As
String) As Long

Public Sub CalculatePlanets()

Dim ret As Long
Dim x As Double
Dim y As Double
Dim vals As Range

ReDim v(0 To anzAttribs - 1) As Double

For pl = 1 To anzPlanets

'Fill vector v() with double values from spreadsheet
Set vals = Range(ActiveCell.Offset(1, pl),
ActiveCell.Offset(anzAttribs, pl))
For at = 0 To anzAttribs - 1
v(at) = CDbl(vals.Range("A" & (at + 1)).Value)
Next at

'x and y are passed by reference and after the function call
contain the results!
x = 99.99
y = 88.88
ret = 5

MsgBox "Start calling SemRaumTest4.Dll" & vbNewLine & _
"Parameter x = " & CStr(x) & vbNewLine & _
"Parameter y = " & CStr(y) & vbNewLine & _
"returnvalue = " & CStr(ret), vbOKOnly

ret = CalcPlanetCoordinates(v, x, y, "")

MsgBox "End calling SemRaumTest4.Dll" & vbNewLine & _
"Parameter x = " & CStr(x) & vbNewLine & _
"Parameter y = " & CStr(y) & vbNewLine & _
"returnvalue = " & CStr(ret), vbOKOnly

If ret = 5 Then
MsgBox "DLL function was not executed!", vbOKOnly
ret = 0
End If

'Write results to spreadsheet
If ret = 0 Then
ActiveCell.Offset(21, pl).Value = x
ActiveCell.Offset(22, pl).Value = y
Dim name As String
name = ActiveCell.Offset(0, pl).Text
CreateNewPlanetPoint x, y, name, pl
Else
ActiveCell.Offset(21, pl).Value = "DLL-Fehler " & CStr(ret)
ActiveCell.Offset(22, pl).Value = "DLL-Fehler " & CStr(ret)
End If
Next pl

Application.ScreenUpdating = True

End Sub

Has somebody an idea, what is happening here? I am totaly clueless at
the moment and would appreciate any help.

I am looping through a range of cells and want to pass a the value to
another function as a string. Actually, it doesn't have to be a string,
I just am not sure how to pass it. I made test1 a string and then made
the value of test1 = the value of the cell then tried to pass as a string
but I get a ByReg argument type missmatch error. What concept am I
missing here?

Sub Looper()

Dim ColA As Range
Dim ColB As Range
Dim counter As Long
Dim rowNumber As Integer
Dim cellNumber As Integer
Dim test1, test2, test3 As String

Set ColA = Sheets("Puzzle").Range("A1:P16")
Set ColB = Sheets("Puzzle").Range("R1:AH16")
For rowNumber = 1 To 16
'For rowNumber = 1654 To 4086
'Set ColA = Sheets("Puzzle").Range(Cells(rowNumber, 1), Cells
(rowNumber, 16))

For cellNumber = 1 To 16
test1 = ColA.Cells(rowNumber, cellNumber)

If test1 <> "" Then

'If ((Cells(rowNumber, 15).Value = "DI" Or Cells
(rowNumber, 15).Value = "DO") _
' And Cells(rowNumber, 23).Value <> "N/A") Then
' CreateDigitalDoc ColA, wordDocDigital
'ElseIf (Cells(rowNumber, 23).Value <> "N/A") Then
' CreateAnalogDoc ColA, wordDocAnalog
'End If
'Next cellNumber
ColB.Cells(rowNumber, cellNumber) = ColA.Cells
(rowNumber, cellNumber)
test2 = CStr(test1)
UpdateAll rowNumber, cellNumber, test2
End If
Next cellNumber
Next rowNumber

End Sub

Sub UpdateAll(rowNumber As Integer, cellNumber As Integer, test2 As
String)
'do some stuff here
End Sub


No luck finding an answer? You could always try Google.