I am trying to do a following in Visual basic script. There is a hierarchy of elements, I have the lowest element (base) and I need to create full hierarchy string . I have a function, which returns parents of an element. That means I can ask for a parent, then parents of the parent, etc.
Example: B is Parent of A, C1, C2 are parents of B, ...
example image
In this example, the result should be array of 3 strings (lines 1,2,3), each containing the full hierarchy for the base element A.
I've tried for loops, but somehow i cant to put is together. I am not VBS expert and array handling looks pretty clumsy to me. Any tips?
EDIT:
This is my current function:
Function GetAllParents (strServer, strDimension, strElem)
dim strPath
dim strElement
dim strParent
dim lngCount
dim i
dim j
dim k
dim result
result = strElem
strElement = strElem
lngCount = AleaElement.ElementParentsCount (strServer, strDimension, strElement)
if (lngCount > 0) then
for i = 1 to lngCount
strParent = AleaElement.ElementParentsName(strServer, strDimension, strElement, i)
result = result & " " & GetAllParents(strServer, strDimension, strParent)
next
end if
GetAllParents = result
End Function
This is The result I get:
CST_700P36 CST_AM_FAE_1002 CST_RM_FAE_NRTH1 CST_OM_FAE_NRTH CST_RET_SAS_RD1 CST_RET_SAS_MNGMT CST_RETAIL_DIVN CST_TOTAL
CST_TOTAL_I&E
CST_SS_FAE_CUR CST_SS_FAE CST_RET_SAS CST_RET_SAR CST_RETAIL_DIVN CST_TOTAL
CST_TOTAL_I&E
CST_RET_SAS_EX_VIR
CST_RETAIL_ALL CST_RETAIL CST_ALL_COST
this is the result I need:
CST_700P36 CST_AM_FAE_1002 CST_RM_FAE_NRTH1 CST_OM_FAE_NRTH CST_RET_SAS_RD1 CST_RET_SAS_MNGMT CST_RETAIL_DIVN CST_TOTAL
CST_700P36 CST_AM_FAE_1002 CST_RM_FAE_NRTH1 CST_OM_FAE_NRTH CST_RET_SAS_RD1 CST_RET_SAS_MNGMT CST_RETAIL_DIVN CST_TOTAL_I&E
CST_700P36 CST_AM_FAE_1002 CST_RM_FAE_NRTH1 CST_OM_FAE_NRTH CST_SS_FAE_CUR CST_SS_FAE CST_RET_SAS CST_RET_SAR CST_RETAIL_DIVN CST_TOTAL
CST_700P36 CST_AM_FAE_1002 CST_RM_FAE_NRTH1 CST_OM_FAE_NRTH CST_SS_FAE_CUR CST_SS_FAE CST_RET_SAS CST_RET_SAR CST_RETAIL_DIVN CST_TOTAL_I&E
CST_700P36 CST_AM_FAE_1002 CST_RM_FAE_NRTH1 CST_OM_FAE_NRTH CST_SS_FAE_CUR CST_RET_SAS_EX_VIR
CST_700P36 CST_RETAIL_ALL CST_RETAIL CST_ALL_COST
It looks like the once included parts are not put in again.
Related
I'm trying to add records to an exisiting table called "Topics" (section as of "For Each SelectedTopic In SelectedTopicsCtl.ItemsSelected" in the code below).
When executing the code i always get "Run-time error '3022': The changes you requested to the table were not successful because they would create duplicate values in the index, primary key, or relationship. So it goes wrong at the creation of the Autonumber in the field "ID" (= the only field that is indexed - no duplicates).
When debugging, line "TopicRecord.Update" in the code below is highlighted.
I have read several posts on this topic on this forum and on other forums but still cannot get this to work - i must be overlooking something....
Private Sub Copy_Click()
Dim JournalEntrySourceRecord, JournalEntryDestinationRecord, TopicRecord As Recordset
Dim JournalEntryToCopyFromCtl, JournalEntryToCopyToCtl, JournalEntryDateCreatedCtl, SelectedTopicsCtl As Control
Dim Counter, intI As Integer
Dim SelectedTopic, varItm As Variant
Set JournalEntryToCopyFromCtl = Forms![Copy Journal Entry]!JournalEntryToCopyFrom
Set JournalEntryToCopyToCtl = Forms![Copy Journal Entry]!JournalEntryToCopyTo
Set JournalEntryDateCreatedCtl = Forms![Copy Journal Entry]!JournalEntryDateCreated
Set JournalEntrySourceRecord = CurrentDb.OpenRecordset("Select * from JournalEntries where ID=" & JournalEntryToCopyFromCtl.Value)
Set JournalEntryDestinationRecord = CurrentDb.OpenRecordset("Select * from JournalEntries where ID=" & JournalEntryToCopyToCtl.Value)
Set SelectedTopicsCtl = Forms![Copy Journal Entry]!TopicsToCopy
Set TopicRecord = CurrentDb.OpenRecordset("Topics", dbOpenDynaset, dbSeeChanges)
With JournalEntryDestinationRecord
.Edit
.Fields("InitiativeID") = JournalEntrySourceRecord.Fields("InitiativeID")
.Fields("DateCreated") = JournalEntryDateCreatedCtl.Value
.Fields("Comment") = JournalEntrySourceRecord.Fields("Comment")
.Fields("Active") = "True"
.Fields("InternalOnly") = JournalEntrySourceRecord.Fields("InternalOnly")
.Fields("Confidential") = JournalEntrySourceRecord.Fields("Confidential")
.Update
.Close
End With
JournalEntrySourceRecord.Close
Set JournalEntrySourceRecord = Nothing
Set JournalEntryDestinationRecord = Nothing
For Each SelectedTopic In SelectedTopicsCtl.ItemsSelected
TopicRecord.AddNew
For Counter = 3 To SelectedTopicsCtl.ColumnCount - 1
TopicRecord.Fields(Counter) = SelectedTopicsCtl.Column(Counter, SelectedTopic)
Next Counter
TopicRecord.Fields("JournalEntryID") = JournalEntryToCopyToCtl.Value
TopicRecord.Fields("DateCreated") = JournalEntryDateCreatedCtl.Value
TopicRecord.Update
Next SelectedTopic
TopicRecord.Close
Set TopicRecord = Nothing
End Sub
First, your Dims won't work as you expect. Use:
Dim JournalEntrySourceRecord As Recordset
Dim JournalEntryDestinationRecord As Recordset
Dim TopicRecord As Recordset
Second, it looks like you get your ID included here:
TopicRecord.Fields(Counter)
or Topic is a query that includes it somehow. Try to specify the fields specifically and/or debug like this:
For Counter = 3 To SelectedTopicsCtl.ColumnCount - 1
TopicRecord.Fields(Counter).Value = SelectedTopicsCtl.Column(Counter, SelectedTopic)
Debug.Print Counter, TopicRecord.Fields(Counter).Name
Next Counter
Introduction
I already have a working solution to the problem this question will describe. Being new to programming, I think my solution is fairly ugly, but: 1) I am not sure that’s true, and 2) I don’t see a more elegant solution after a solid week reading around the internet studying. Since I can easily solve the problem on an ad hoc basis using Pivot Tables and the subject spreadsheet is common report style, I am thinking that many others have already solved this problem (but I haven’t found it or know the keywords to search for). I will provide the raw data, the desired output, the code I currently have working, and some alternatives that I’ve looked at, but didn’t use and why. I am asking you for a better programming approach -- if you see one -- or at least validation that my method was reasonably as efficient as it could be done. Thank you.
The Raw Data
Below is an example of a report which contains data to be summarized:
Report #| Assignee| Type of Report| Department| Status
1 | Shannon| Ad hoc| Accounting| Declined
2 | Shannon| Ad hoc| Accounting| Completed
3 | Shannon| Change| Accounting| New
4 | Shannon| Change| Shipping| In Progress
5 | Shannon| Training| Shipping| Declined
6 | Shannon| Training| CustService| Completed
7 | Shannon| Training| CustService| New
8 | Jason| Ad hoc| CustService| In Progress
9 | Jason| Change| CustService| Declined
10 | Jason| Ad hoc| Accounting| Completed
11 | Jason| Training| Accounting| New
12 | Thomas| Training| Accounting| In Progress
13 | Jason| Change| Shipping| Declined
14 | Jason| Ad hoc| Shipping| Completed
15 | Thomas| Ad hoc| CustService| New
16 | Jason| New| CustService| In Progress
17 | Thomas| New| CustService| Declined
18 | Thomas| Change| CustService| Completed
19 | Thomas| Ad hoc| Shipping| New
20 | Thomas| Change| Shipping| In Progress
-Continues in similar fashion until:-
545 | Phyllis| New| Accounting| Declined
Desired Output
The data needs to be summarized in a manner similar to what is below. That is, it is filtered by Assignee name, and a count of the subcategories is the output for each parent category. (Note: This output could be easily obtained using a Pivot Table ad hoc, but I want to put it into a running table that builds over time programmatically for trend analysis.)
Shannon: Type of Report Department Status
Ad hoc= 25 Accounting= 45 Declined = 12
Change= 13 CustService= 2 In Progress= 24
Training= 3 Shipping= 75 New= 56
New= 81 Completed= 30
Jason: Type of Report Department Status
Ad hoc= 12 Accounting= 21 Declined = 0
Change= 3 CustService= 23 In Progress= 12
Training= 20 Shipping= 4 New= 12
New= 13 Completed= 24
-Continues for each "Assignee"-
The summarizing I am doing is very similar to what you get from a PivotTable, and that's currently how the manual process gets the data. I need to get the data, however, and put into a daily tracking table which retains the historical counts and is used for trend analysis on each assignee, so a PivotTable by itself isn’t a solution.
Currently Working Code
This is the entire piece of working code, including two subs that are called which are appended to the end:
Sub CollateData()
Dim HdrNm As New Collection 'Collection used to read and reference column indices.
'Variables used for referencing the "Assigned To" column
Dim Assignee As New Scripting.Dictionary
Dim nmAssignee As New Scripting.Dictionary
Dim Asgn As String
Dim a As Integer
Dim aKey As Variant
'Variables used for referencing the "Type of Report" column
Dim TypRep As New Scripting.Dictionary
Dim nmTypRep As New Scripting.Dictionary
Dim arrTypRep() As Integer
Dim Typ As String
Dim t As Integer
'Variables used for referencing the "Department" column
Dim Dept As New Scripting.Dictionary
Dim nmDept As New Scripting.Dictionary
Dim arrDept() As Integer
Dim Bus As String
Dim b As Integer
'Variables used for referencing the "Task Status" column
Dim TskStatus As New Scripting.Dictionary
Dim nmTskStatus As New Scripting.Dictionary
Dim arrTskStatus() As Integer
Dim Tsk As String
Dim s As Integer
'Other variables
Dim DataWS As Worksheet
Dim ScratchWS As Worksheet
Dim lastrow As Integer, x As Integer
Set DataWS = ThisWorkbook.Worksheets("SheetWithRawData")
lastrow = DataWS.Cells(Rows.Count, 11).End(xlUp).Row
Call ReadHeaderRow(DataWS, HdrNm) 'Fills the HdrNm collection with column index using column headers for keys
'Initialize variables for the loop that follows
a = 1
t = 1
b = 1
s = 1
'This next seciont/first loop goes through the report to identify a unique list of assignees and category lists _
' which need to be summed. These lists will be used to ReDim the 2-dimensional arrays to appropriate _
' size, as well as reference the elements of the 2D array(s).
'
' NOTE: I am using the seemingly duplicative Dictionaries (e.g. TypRep & nmTypeRep) in order to have _
' access to the category as both a string and as an integer/index.
For x = 2 To lastrow
If Not Assignee.Exists(DataWS.Cells(x, HdrNm("Assigned to")).Value) Then
Assignee.Add DataWS.Cells(x, HdrNm("Assigned to")).Value, a
nmAssignee.Add a, DataWS.Cells(x, HdrNm("Assigned to")).Value
a = a + 1
End If
If Not TypRep.Exists(DataWS.Cells(x, HdrNm("Type of Report")).Value) Then
TypRep.Add DataWS.Cells(x, HdrNm("Type of Report")).Value, t
nmTypRep.Add t, DataWS.Cells(x, HdrNm("Type of Report")).Value
t = t + 1
End If
If Not Dept.Exists(DataWS.Cells(x, HdrNm("Department")).Value) Then
Dept.Add DataWS.Cells(x, HdrNm("Department")).Value, b
nmDept.Add b, DataWS.Cells(x, HdrNm("Department")).Value
b = b + 1
End If
If Not TskStatus.Exists(DataWS.Cells(x, HdrNm("Task Status")).Value) Then
TskStatus.Add DataWS.Cells(x, HdrNm("Task Status")).Value, s
nmTskStatus.Add s, DataWS.Cells(x, HdrNm("Task Status")).Value
s = s + 1
End If
Next x
'Assign the appropriate dimensions to the following 2D arrays
ReDim arrTypRep(1 To Assignee.Count, 1 To TypRep.Count)
ReDim arrDept(1 To Assignee.Count, 1 To Dept.Count)
ReDim arrTskStatus(1 To Assignee.Count, 1 To TskStatus.Count)
'The following, second loop now goes through and sums up the count of each category element for each _
' Assignee. Using this technique, I only go through the list/report once (or twice, if you consider _
' the previous loop to dimension the arrays) in order to tabulate the desired data.
For x = 2 To lastrow
Asgn = DataWS.Cells(x, HdrNm("Assigned to")).Value
Typ = DataWS.Cells(x, HdrNm("Type of Report")).Value
Bus = DataWS.Cells(x, HdrNm("Department")).Value
Tsk = DataWS.Cells(x, HdrNm("Task Status")).Value
arrTypRep(Assignee.item(Asgn), TypRep.item(Typ)) = arrTypRep(Assignee.item(Asgn), TypRep.item(Typ)) + 1
arrDept(Assignee.item(Asgn), Dept.item(Bus)) = arrDept(Assignee.item(Asgn), Dept.item(Bus)) + 1
arrTskStatus(Assignee.item(Asgn), TskStatus.item(Tsk)) = arrTskStatus(Assignee.item(Asgn), TskStatus.item(Tsk)) + 1
Next x
'Now to generate the output of the data we collected:
On Error Resume Next
Application.DisplayAlerts = False
With ThisWorkbook
.Worksheets("DesiredOutput").Delete
.Worksheets.Add after:=.Worksheets(1)
End With
Application.DisplayAlerts = True
On Error GoTo 0
Set ScratchWS = ThisWorkbook.ActiveSheet
ScratchWS.Name = "DesiredOutput"
x = 1
'Loop through each Assignee and dump out the collected counts
For Each aKey In Assignee
Call OutputData("Type of Report", Assignee, nmAssignee, aKey, TypRep, nmTypRep, arrTypRep, x)
Call OutputData("Department", Assignee, nmAssignee, aKey, Dept, nmDept, arrDept, x)
Call OutputData("Task Status", Assignee, nmAssignee, aKey, TskStatus, nmTskStatus, arrTskStatus, x)
Next aKey
Range("B1").ColumnWidth = 3
Range("A1, C1").EntireColumn.AutoFit
End Sub
****************************************************************************
****************************************************************************
Sub OutputData(Title As String, Assignee As Scripting.Dictionary, nmAssignee As Scripting.Dictionary, _
aKey As Variant, ReportCategory As Scripting.Dictionary, nmReportCategory As Scripting.Dictionary, _
arrCategory() As Integer, x As Integer)
Dim CatKey As Variant
With Cells(x, 2)
.Value = Title
.Font.Bold = True
End With
x = x + 1
For Each CatKey In ReportCategory
Cells(x, 1).Value = nmAssignee.item(Assignee.item(aKey))
Cells(x, 3).Value = nmReportCategory.item(ReportCategory.item(CatKey))
Cells(x, 4).Value = arrCategory(Assignee.item(aKey), ReportCategory.item(CatKey))
x = x + 1
Next CatKey
x = x + 1
End Sub
**************************************************************************
**************************************************************************
Private Sub ReadHeaderRow(TargetWS As Worksheet, HdrNm As Collection)
Dim lastcolumn As Integer
Dim x As Integer
lastcolumn = TargetWS.Cells(1, Columns.Count).End(xlToLeft).Column
For x = 1 To lastcolumn
HdrNm.Add TargetWS.Cells(1, x).Column, TargetWS.Cells(1, x).Value
Next x
End Sub
Other Possible Solutions Considered/Discarded
Looping through list for each Assignee
I thought about generating a dictionary/collection of assignees and then looping through the report gathering the data for each assignee on each pass, but the number of assignees could change (go up), and the report list could go up, and thus many extraneous passes through the list.
Jagged Arrays/Collections/Dictionaries
I was excited when I first learned that I could do a dictionary of dictionaries (array of arrays, etc), but as I understand it, I can't use the first dictionary for assignees (1st Dimension) and a second dictionary for all of one category (e.g. Type of Report) as the second dimension. I would actually need to create a separate dictionary for each assignee and category. In other words, if I had just one category (Type of Report) and 15 assignees, I would actually need to create 16 dictionaries: 1st dictionary would be "Assignee" --the assignee's name as the key, and 2nd through 16th dictionaries (TypRep1 through TypRep15) as the items corresponding to the keys in dictionary Assignee. Plus, I cannot create the dictionaries dynamically as the number of Assignees might change, so this method was out for me, unless I've misunderstood something important (always possible). My knowledge of jagged datatypes comes from here: http://bytecomb.com/collections-of-collections-in-vba/
Custom Data Type
I haven't tried this because I just came across it, and I don't know much about it, but maybe this problem would be solved as a custom data type. I'm going to go read about them more, but perhaps that's a better solution in a way I do not yet understand.
Concluding Statement
I know this was a lot to read, sorry. Thanks for sticking this far. I would greatly appreciate any suggestions on how to achieve what my code above does achieve. I feel confident that the reason I haven't found a better way is that this problem's solution is obvious to everyone but me, and it seems like it would be something anyone coding in VBA/Excel would come across with some frequency. Thank you for your helpful input.
We use objects in programming. Most computers have Excel, so you could get excel to do it for you.
Windows come with an object, which I think of as a datatype. A created in memory, disconnected recordset.
So you would do
rs.filter = "Assignee='Shannon' AND Status='Cancelled'"
then
msgbox rs.recordcount
Gives you the number.
Or you can sort and enumerate.
This cuts lines from the top or bottom of a file.
cscript scriptname.vbs "" t x 5 <infile.txt >outfile.txt
Set Arg = WScript.Arguments
set WshShell = createObject("Wscript.Shell")
Set Inp = WScript.Stdin
Set Outp = Wscript.Stdout
Set rs = CreateObject("ADODB.Recordset")
With rs
.Fields.Append "LineNumber", 4
.Fields.Append "Txt", 201, 5000
.Open
LineCount = 0
Do Until Inp.AtEndOfStream
LineCount = LineCount + 1
.AddNew
.Fields("LineNumber").value = LineCount
.Fields("Txt").value = Inp.readline
.UpDate
Loop
.Sort = "LineNumber ASC"
If LCase(Arg(1)) = "t" then
If LCase(Arg(2)) = "i" then
.filter = "LineNumber < " & LCase(Arg(3)) + 1
ElseIf LCase(Arg(2)) = "x" then
.filter = "LineNumber > " & LCase(Arg(3))
End If
ElseIf LCase(Arg(1)) = "b" then
If LCase(Arg(2)) = "i" then
.filter = "LineNumber > " & LineCount - LCase(Arg(3))
ElseIf LCase(Arg(2)) = "x" then
.filter = "LineNumber < " & LineCount - LCase(Arg(3)) + 1
End If
End If
Do While not .EOF
Outp.writeline .Fields("Txt").Value
.MoveNext
Loop
End With
One approach for you would be to put your 4 criteria into 4 arrays- Assignee, Status, Dept, theotherone.
For each a in assignee()
For each b in Status()
For each c in Dept()
For each d in other()
.filter = "assinnee=" & a & "AND Status=" & b & "And dept=" & c
msgbox .recordcount
Next
Next
Next
Next
I'm studying computing at AS Level in England, and the language we are using is VB6.
I am working on out assignment which has to be completed for 18/12/2014.
The project is for a hypothetical situation where a running club needs software to do the following:
- Add Members
- View Members
- Edit Member Information
- Search for Members
- Delete Members
- Add Training Information for Members
- View Training Information
- Compare Training Information
- Automatically select a team of runners based upon the number of hours trained for
Here's my code for the problem form:
Option Explicit
Private Sub CmdExitFromSelectTeam_Click()
Unload Me
End Sub
Private Sub SelectTeam()
Dim TrainingChannel As Integer
Dim Training As TrainingRecord
Dim MemberChannel As Integer
Dim Member As MemberRecord
Dim MemberRecordPointer As Integer
Dim TotalHoursTrained As Single
Dim TrainingRecordPointer As Integer
Dim FoundAtLeastOneRecord
FoundAtLeastOneRecord = False
MemberChannel = FreeFile
Open MemberFile For Random As MemberChannel Len = MemberLength
MemberRecordPointer = 1
Get MemberChannel, MemberRecordPointer, Member
Do While Not EOF(MemberChannel)
TotalHoursTrained = 0
TrainingRecordPointer = 1
TrainingChannel = FreeFile
Open TrainingFile For Random As TrainingChannel Len = TrainingLength
Get TrainingChannel, MemberRecordPointer, Training
Do While Not EOF(TrainingChannel)
If Member.ID = Training.MemberID Then
TotalHoursTrained = Round(TotalHoursTrained, 1) + Round(Training.TimeTaken, 1)
End If
TrainingRecordPointer = TrainingRecordPointer + 1 (*)
Get TrainingChannel, MemberRecordPointer, Training
Loop
Close TrainingChannel
LstTeamSelectDisplayTeam.AddItem TotalHoursTrained, 1
LstTeamSelectDisplayTeam.AddItem Member.ID, 2
LstTeamSelectDisplayTeam.AddItem Member.Forename, 3
LstTeamSelectDisplayTeam.AddItem Member.Surname, 4
MemberRecordPointer = MemberRecordPointer + 1
Get MemberChannel, MemberRecordPointer, Member
Loop
Close MemberChannel
End Sub
Private Sub Form_Load()
SelectTeam
End Sub
When this form (FrmSelectTeam.frm) is loaded at run time, the line: marked with (*) is highlighted as the debug line.
I have no idea what the problem is, and I'd appreciate all the help I can get, so thanks in advance!!!
James
In VB6, the maximum value for the Integer data type is 32767. You are apparently exceeding that limit in the (*) statement. You can change it to a 32-bit integer by declaring it long:
Dim TrainingRecordPointer As Long
#xpda's answer is almost certainly correct.
One handy debugging trick for an error like this, is to modify your code slightly, as below:
Open MemberFile For Random As MemberChannel Len = MemberLength
MemberRecordPointer = 1
Get MemberChannel, MemberRecordPointer, Member
Do While Not EOF(MemberChannel)
TotalHoursTrained = 0
TrainingRecordPointer = 1
TrainingChannel = FreeFile
Open TrainingFile For Random As TrainingChannel Len = TrainingLength
Get TrainingChannel, MemberRecordPointer, Training
Do While Not EOF(TrainingChannel)
If Member.ID = Training.MemberID Then
TotalHoursTrained = Round(TotalHoursTrained, 1) + Round(Training.TimeTaken, 1)
End If
If TrainingRecordPointer > 32750 Then
Debug.Print TrainingRecordPointer
End If
TrainingRecordPointer = TrainingRecordPointer + 1
Get TrainingChannel, MemberRecordPointer, Training
Loop
Close TrainingChannel
LstTeamSelectDisplayTeam.AddItem TotalHoursTrained, 1
LstTeamSelectDisplayTeam.AddItem Member.ID, 2
LstTeamSelectDisplayTeam.AddItem Member.Forename, 3
LstTeamSelectDisplayTeam.AddItem Member.Surname, 4
MemberRecordPointer = MemberRecordPointer + 1
Get MemberChannel, MemberRecordPointer, Member
Loop
Close MemberChannel
Alternatively, you can put a breakpoint in the added If-Then, and step through using the debugger.
Well thankyou for your feedback, but what was actually the cause (Believe it or not) was simple human error; I put "Get TrainingChannel, MemberRecordPointer, Training" instead of "Get TrainingChannel, TrainingRecordPointer, Training"
It's so annoying that something as simple as that could cause such a big problem.
But once again, thanks!!
I have an Excel sheet which has 200 columns. Now number of rows are 3500. So i have to search a string if it presents within any column for each row. Now to make the process fatser,I am looking for any alternate instead of Looping technique. Is there any such?
IntRow6 = 2
DataCount = 0
Do While objSheet6.Cells(IntRow6,1).Value <> ""
For DataCount = 0 to UBound(VMHArray)
IntClmn3 = 1
Do While 1 = 1
If objSheet6.Cells(IntRow6,IntClmn3).Value = VMHArray(DataCount) Then
objSheet6.Cells(IntRow6,IntClmn3+2).Value=objSheet6.Cells(IntRow6,IntClmn3+5).Value
Exit Do
End If
IntClmn3 = IntClmn3 + 1
Loop
Next
IntRow6 = IntRow6 + 1
Loop
The above is taking to much time, thus i am looking for an equivalent VBScript code which can run more faster search.
EDIT:
ParentColmnCount=ParentColmnCount-1
IntRow6=2
DataCount=0
Do While objSheet6.Cells(IntRow6,1).Value <> ""
For DataCount=0 to UBound(VMHArray)
If objSheet6.Range(objSheet6.Cells(IntRow6,1),objSheet6.Cells(IntRow6,ParentColmnCount)).Find(VMHArray(DataCount)) <> Nothing Then
MsgBox("Hi")
End If
Next
IntRow6=IntRow6+1
Loop
I'm getting any error saying that, "Object variable not set" error at the Range line of the above code.
UPDATE
I have updated my code as per your suggestion,and modified the declaration of variables as below:
Option Explicit
Dim objExcel1,objWorkbook
Dim strPathExcel1
Dim objSheet6,objSheet3
Dim IntRow6,IntRow3
Dim IntClmn3
Dim DataCount,ParentColmnCount
Dim Falg
Dim TaskCounter
Dim r As Range
Dim s As Variant
But I am getting the error again: Expected end of statement" in the line "Dim r As Range"
Check out Range.Find (which returns a Range object). It's faster than a loop.
Example:
Sub Test()
Dim r As Range
Dim matched As Range
'Get the second row
Set r = Sheet1.Range("2:2")
Set matched = r.Find("myString")
'Do stuff with matched
End Sub
UDPATE:
Assuming you are using CreateObject("Excel.Application"), then the Range object will be present (as CreateObject will return an instance of Excel which contains Range objects and functionality).
For further proof, you're already looping through the worksheet using Range objects (Cells is a Range object).
UPDATE:
Here's a more advanced example. Assume the following data in on Sheet1:
fred ethel ricky bobby 1 2 3 4
lucy myrtle fonzy rickie 1 2 3 4
joanie chachie donna patty 1 2 3 4
selma homer lisa bart 1 2 3 4
You can loop through the ranges like so:
Sub test()
Dim r As Range
Dim names(3) As String
Dim s As Variant
names(0) = "ethel"
names(1) = "fonzy"
names(2) = "patty"
names(3) = "selma"
For Each s In names
For Each r In Sheet1.Cells.CurrentRegion.Find(s)
r.Offset(0, 4).Value = r.Offset(0, 4).Value + 1000
Next r
Next s
End Sub
After the routine is done, the data is now:
fred ethel ricky bobby 1 1002 3 4
lucy myrtle fonzy rickie 1 2 1003 4
joanie chachie donna patty 1 2 3 1004
selma homer lisa bart 1001 2 3 4
UPDATE:
I just saw your comment on your question (and edited your question to include the updated code).
You're getting "Object variable not set" on that line because you cannot use <> comparisons with objects. Change the line to read:
If Not objSheet6.Range(objSheet6.Cells(IntRow6,1),objSheet6.Cells(IntRow6,ParentColmnCount)).Find(VMHArray(DataCount)) Is Nothing Then
I've created a function called EnergyPrice with the following code:
Here's the pricetable I'm looking up from
Prijstabel
fixed variable
Startdate Einddate gas electra gas electra
€/a €/a ct/KWh ct/KWh
1-1-2010 1-7-2010 181,00 235,00 0,11 0,33
1-7-2010 1-1-2011 362,00 470,00 0,33 1,30
1-1-2011 1-7-2011 191,00 245,00 0,22 0,65
1-7-2011 1-1-2012 162,35 208,25 0,19 0,55
1-1-2012 1-7-2012 324,70 416,50 0,37 1,11
And here's the relevant code
Public Enum Energietype
v_gas = 1
v_electricity = 2
End Enum
Public Enum FixedOrVariable
v_fixed = 1
v_variable = 2
End Enum
Public Function EnergyPrice(PriceDate As Date, E_type As Energietype, variabel As FixedOrVariable) As Variant
Dim PrijsTable As Range
Dim RowNr As Integer
Dim Found As Boolean
Dim KolomNr As Integer
Set PrijsTable = Range("EnergyPriceTable")
If PrijsTable.Columns.Count <> 6 Then Err.Raise Number:=vbObjectError + 1000, Description:="No valid valid pricetable defined"
RowNr = 1
Found = False
While Not (Found) And (RowNr <= PriceTable.Rows.Count)
Found = (PriceTable.Cells(RowNr, 1).Value <= PriceDate) And (PriceTable.Cells(RowNr, 2) > PriceDate)
If Not (Found) Then RowNr = RowNr + 1
Wend
If Found Then
If E_type = v_gas Then KolomNr = 1
If E_type = v_elektra Then KolomNr = 2
If variabel = v_variabel Then KolomNr = KolomNr * 2
KolomNr = KolomNr + 2
EnergyPrice = PriceTable.Cells(RowNr, KolomNr).Value
Else
EnergyPrice = Empty
End If
End Function
The question is how do I use the above enums in an Excel spreadsheet? So I can enter a formula like:
If I use the numbers 1,2 the functions works fine, but I want to use the enum names.
Can this be done using only Excel VBA?
If you add the enums to the workbook as defined names, you can pass them into functions and the value that is passed is the actual value you set the enum for. Do this manually or via VBA if you prefer.
Example:
ActiveWorkbook.Names.Add Name:="v_gas", RefersToR1C1:="=1"
ActiveWorkbook.Names.Add Name:="v_fixed", RefersToR1C1:="=2"
The only way I see, is by defining Names in your workbook, assigning them the constants of your Enums.
From the menu: Insert ... Name .... Define
Name: v_gas
Refers to: =1
Alternatively, you could create those names by VBA, but that has no interest, since it will be a 1 shot (names are saved with the workbook).
By using such names, the users will be able to use F3 while entering the formula.