I am trying to write a simple code that filters out data based on some condition.
My code is below :
Public Function fGetUniqInitiative(Optional ByVal uniqInitiative As Variant, Optional ByVal filter1 As Variant, Optional ByVal filter2 As Variant, Optional ByVal filter3 As Variant, Optional ByVal vartempData As Variant) As Variant()
Dim lngcounterinitiatve As Long
Dim lngVarData As Long
Dim lngfilter1 As Long
Dim lngfilter2 As Long
Dim lngfilter3 As Long
Dim boolfilter1 As Boolean
Dim boolfilter2 As Boolean
Dim boolfilter3 As Boolean
Dim varUniqueList() As Variant
Dim lnguniqueinitcount As Long
lnguniqueinitcount = 0
For lngcounterinitiative = LBound(uniqInitiative) To UBound(uniqInitiative)
boolfilter1 = False
boolfilter2 = False
boolfilter3 = False
For lngVarData = LBound(vartempData) To UBound(vartempData)
If uniqInitiative(lngcounterinitiative) = vartempData(lngVarData, 2) Then
For lngfilter1 = LBound(filter1) To UBound(filter1)
If vartempData(lngVarData, 9) = filter1(lngfilter1) Then
boolfilter1 = True
Exit For
End If
Next lngfilter1
For lngfilter2 = LBound(filter2) To UBound(filter2)
If vartempData(lngVarData, 10) = filter2(lngfilter2) Then
boolfilter2 = True
Exit For
End If
Next lngfilter2
For lngfilter3 = LBound(filter3) To UBound(filter3)
If vartempData(lngVarData, 11) = filter3(lngfilter3) Then
boolfilter3 = True
Exit For
End If
Next lngfilter3
If boolfilter1 = True Or boolfilter2 = True Or boolfilter3 = True Then
Exit For
Else
lnguniqueinitcount = lnguniqueinitcount + 1
ReDim varUniqueList(1 To lnguniqueinitcount)
End If
End If
Next lngVarData
Next lngcounterinitiatve
fGetUniqInitiative = varUniqueList
End Function
However, when i try to compile the code it gives the error "Invalid Next Control Variable reference". I have googled it quite a bit and all the solutions say that i must be missing closing the loop which i don't think is the case in my code. Anyone could point what am i missing?
lngcounterinitiative is spelled wrong in "Next lngcounterinitiatve".Try changing that.
Related
i'm currently using below function to find a MS project task based on custom field value, it works perfectly when a parent task object is provided, it only loops through children tasks. The problem is that now in plan target task could be placed any where in plan and it takes some time looping through all the ~3k tasks in plan trying to find the correct task based on custom field value. Is there a way i could do this faster?
**'sub to test Function**
Public Sub TestFunction()
Dim TaskObject as Object
Dim MSapp as Object '<- MS project application
Dim ErrMsg as String
set TaskObject = funGetTaskByFieldRef(objMSPapp:=MSapp,
fieldValue:="Key1234",
fieldName:= "customForeingKeyField",
ErrMsg:= ErrMsg)
if TaskObject is nothing then
MsgBox ErrMsg
else
Debug.Print TaskObject.UniqueID & " - " & TaskObject.Name
end if
End Sub
**'Function - - -**
Public Function funGetTaskByFieldRef(ByRef objMSPapp As Object, ByVal fieldValue As String, _
ByVal fieldName As String, _
Optional ByRef objParentTask As Object, _
Optional ByRef ErrMsg As String = vbNullString) As Object
'<VARIABLES>
Dim obMSPprj As Object
Dim tsk As Object
Dim tmpValue As String
'</VARIABLES>
'<FUN> ---
'set temporal var Microsoft Project
Set obMSPprj = objMSPapp.ActiveProject
'using project
With obMSPprj
'check if parent task has been provided
If Not objParentTask Is Nothing Then
'loop through each child
For Each tsk In objParentTask.OutlineChildren
tmpValue = funSetGetMSPval(objMSPapp, tsk, 0, "Get", fieldName)
If tmpValue = fieldValue Then
'retunr UID
Set funGetTaskByFieldRef = tsk
'exit function
Exit Function
End If
Next tsk
Else
'loop through each task
For Each tsk In .Tasks
tmpValue = funSetGetMSPval(objMSPapp, tsk, 0, "Get", fieldName)
If tmpValue = fieldValue Then
'retunr UID
Set funGetTaskByFieldRef = tsk
'exit function
Exit Function
End If
Next tsk
End If
End With
'if there is no exact match for task name return -1
Set funGetTaskByFieldRef = Nothing
ErrMsg = "Task not found"
'<FUN> ---
End Function
**'Encapsulated sub-function **
Public Function funSetGetMSPval(ByRef objMSPapp As Object, ByRef objEntObj As Object, _
ByVal intPjFieldType As Integer, ByVal strAction As String, _
Optional ByVal strFldName As String, _
Optional ByVal strVal As String) As Variant
'pjProject = 2
'pjResource =1
'pjTask = 0
With objMSPapp
Select Case strAction
Case "Set"
On Error Resume Next
objEntObj.SetField .FieldNameToFieldConstant(strFldName, intPjFieldType), strVal
If Not Err.Number <> 0 Then
'catch error
End If
On Error GoTo 0
funSetGetMSPval = True
Case "Get"
funSetGetMSPval = objEntObj.getfield(.FieldNameToFieldConstant(strFldName, intPjFieldType))
End Select
End With
End Function
Hope there is someone that has a better way to do this.
thank you.
regards.
Is there a way i could do this faster?
Yes, use the Find method.
Public Sub FindTask()
Dim TaskObject As Object
Dim MSapp As Object
Set MSapp = Application
Dim found As Boolean
found = MSapp.Find(Field:="customForeingKeyField", Test:="equals", Value:="Key1234")
If found Then
Set TaskObject = MSapp.ActiveCell.Task
Debug.Print TaskObject.UniqueID & " - " & TaskObject.Name
Else
MsgBox "Task not found"
End If
End Sub
In the code I am posting, I am using a check box called "ACDS Test" and whenever it is checked it creates a sheet, then when it becomes unchecked it calls the upper function and deletes the sheet.
I am trying to add a message box that essentially works like a fail safe to ensure they want to delete the page. If they say they do not want to delete the page then I want the checkbox to stay checked.
For some reason I am getting this error message when I try to pass the value to make sure the checkbox stays checked and I cannot figure out why.
The error comes up on the line:
Sub ACDSTest_Click(CorrectValue As Integer)
And the specific error is: "Compile error: Procedure Declaration does not match description of event or procedure having the same name".
Any help is much appreciated! IF any more clarification is needed please feel free to ask!
Sub DeleteWorksheet(NameSheet As String)
Dim Ans As Long
Dim t As String
Dim CorrectValue As Integer
Dim i As Long, k As Long
k = Sheets.Count
Ans = MsgBox("Would you like to take this test off of the form?", vbYesNo)
Select Case Ans
Case vbYes
'Code reads through each page and finds one with corresponding name to string t
'Once it finds the correct page, it deletes it
For i = k To 1 Step -1
t = Sheets(i).Name
If t = NameSheet Then
Sheets(i).Delete
End If
Next i
CorrectValue = 0
Case vbNo
CorrectValue = 1
End Select
End Sub
Sub ACDSTest_Click(CorrectValue As Integer)
Dim NameSheet As String
Dim NameValue As String
NameSheet = "ACDS"
NameValue = "ACDS Test"
If ACDSTest.Value = True Then
CreateWorksheet (NameSheet), (NameValue)
Worksheets("Sheet1").Activate
Else
DeleteWorksheet (NameSheet)
If CorrectValue = 1 Then
ActiveSheet.Shapes("ACDS Test").ControlFormat.Value = 1
End If
End If
End Sub
The issue here is that the CorrectValue variable as you define it in DeleteWorksheet does not exist in the context of the
variable does not exist in context of the ACDSTest_Click subroutine. This is because variables defined within subroutines or functions are local to those functions. To correct this I would convert DeleteWorksheet to a function such as the below.
Further, the event that fires Private Sub ACDSTest_Click() cannot handle passing a value to that function, so changing it to Sub ACDSTest_Click(CorrectValue As Integer) causes an error.
Function DeleteWorksheet(ByVal SheetName As String) As Boolean
On Error GoTo SheetDNE
SheetName = Sheets(SheetName).Name 'Check if sheet exists w/o other objects
On Error GoTo 0
Select Case MsgBox("Would you like to take this test off of the form?", vbYesNo)
Case vbYes
Application.DisplayAlerts = False
Sheets(SheetName).Delete
Application.DisplayAlerts = True
DeleteWorksheet = True
Case Else: DeleteWorksheet = False
End Select
Exit Function 'Exit The Function w/o error
SheetDNE: 'Sheet Does Not Exist
MsgBox "The indicated sheet, " & SheetName & ", does not exist", vbOKOnly
End Function
And
Private Sub ACDSTest_Click()
Dim NameSheet As String
Dim NameValue As String
NameSheet = "ACDS"
NameValue = "ACDS Test"
If ACDSTest.Value = True Then
CreateWorksheet (NameSheet), (NameValue)
Worksheets("Sheet1").Activate
Else
If Not DeleteWorksheet(NameSheet) Then _
ActiveSheet.Shapes("ACDS Test").ControlFormat.Value = 1
End If
End Sub
I am receiving a run-time error '1004' on the line .Font.color = vbRed when setting conditional formats. The Sub works great on Excel 2011 for Mac, but fails on Windows.
I've tried rearranging the code, using RGB(255,0,0), setting .ColorIndex, as well as recording a macro and using that code. All failed in windows.
I'm trying to set the font color to red if the cell begins with "Med". The sub is called from here:
Public Const BASE As String = "$D$14"
Dim cols As Long
Dim rows As Long
Dim applyToRange As Range
Dim condition As String
' rows and cols variables set here...
Set applyToRange = Range(BASE, Range(BASE).Offset(rows - 1, cols - 1))
' Med
condition = "Med"
applyTextStringConditionals applyToRange, condition, xlBeginsWith, 0, False
What am I missing?
Private Sub applyTextStringConditionals(ByVal applyToRange As Range, ByVal matchString As String, _
ByVal operator As Long, ByVal color As Long, ByVal stopIfTrue As Boolean)
applyToRange.FormatConditions.Add Type:=xlTextString, String:=matchString, TextOperator:=operator
applyToRange.FormatConditions(applyToRange.FormatConditions.Count).SetFirstPriority
If color = 0 Then
With applyToRange.FormatConditions(1)
.Font.color = vbRed '<--- Error 1004 here
'.TintAndShade = 0
End With
Else
applyToRange.FormatConditions(1).Interior.color = color
End If
applyToRange.FormatConditions(1).stopIfTrue = stopIfTrue
End Sub
UPDATE:
This works, only if it's the first conditional format created:
Set applyToRange = Range(BASE, Range(BASE).Offset(rows - 12, cols - 1))
' Med
condition = "Med"
Stop
applyToRange.FormatConditions.Add Type:=xlTextString, String:=condition, TextOperator:=xlBeginsWith
applyToRange.FormatConditions(applyToRange.FormatConditions.Count).SetFirstPriority
applyToRange.FormatConditions(1).Font.Color = vbRed '-16776961
applyToRange.FormatConditions(1).stopIfTrue = True
But this does not:
Private Sub applyTextStringConditionals(ByVal l_applyToRange As Range, ByVal matchString As String, _
ByVal l_Operator As Long, ByVal setColor As Long, ByVal l_stopIfTrue As Boolean)
l_applyToRange.FormatConditions.Add Type:=xlTextString, String:=matchString, TextOperator:=l_Operator
l_applyToRange.FormatConditions(l_applyToRange.FormatConditions.Count).SetFirstPriority
If setColor = 0 Then
l_applyToRange.FormatConditions.Item(1).Font.Color = vbRed
Else
l_applyToRange.FormatConditions(1).Interior.Color = setColor
End If
l_applyToRange.FormatConditions(1).stopIfTrue = True
end sub
I had previously asked about how to evenly distribute the items in n lists into a single list and was referred to this question: Good algorithm for combining items from N lists into one with balanced distribution?.
I made a practical example of my solution for this in VBA for Excel, since my application for this was resorting my Spotify lists which can be easily pasted into Excel for manipulation. Assumptions are that you have a headerless worksheet (wsSource) of songs with columns A, B, C representing Artist, Song, SpotifyURI respectively, a "Totals" worksheet (wsTotals) containing the sum of songs for each Artist from wsSource sorted in descending order, and a "Destination" worksheet where the new list will be created. Could I get some suggestions to improve this? I was going to get rid of the totals worksheet and have this portion done in code, but I have to go and I wanted to go ahead and put this out there. Thanks!
Sub WeaveSort()
Dim wb As Workbook
Dim wsDest As Worksheet
Dim wsSource As Worksheet
Dim wsTotals As Worksheet
Dim i As Integer
Dim iLast As Integer
Dim iDest As Integer
Dim iSource As Integer
Dim iOldRow As Integer
Dim iNewRow As Integer
Dim dDiff As Double
Dim dDiffSum As Double
Set wb = ThisWorkbook
Set wsTotals = wb.Worksheets("Totals")
Set wsSource = wb.Worksheets("Source")
Set wsDest = wb.Worksheets("Dest")
iLast = wsTotals.Range("A1").End(xlDown).Row - 1
For i = 2 To iLast
iSource = wsTotals.Range("B" & i).Value
iDest = wsDest.Range("A99999").End(xlUp).Row
If i = 2 Then
wsDest.Range("A1:C" & iSource).Value2 = wsSource.Range("A1:C" & iSource).Value2
wsSource.Range("A1:C" & iSource).Delete (xlShiftUp)
GoTo NextI
End If
dDiff = iDest / iSource
dDiffSum = 0
iNewRow = 0
For iOldRow = 1 To iSource
dDiff = iDest / iSource
dDiffSum = dDiffSum + dDiff
iNewRow = Round(dDiffSum, 0)
wsSource.Rows(iOldRow).Copy
wsDest.Rows(iNewRow).Insert xlShiftDown
iDest = iDest + 1
Next iOldRow
wsSource.Range("A1:C" & iSource).Delete (xlShiftUp)
NextI:
Next i
End Sub
Great question! I would take an object oritentated approach. Also I didn;t think it was clear what the logic was so here is my answer. Two classes and one normal module. Save these separately with the filenames ListManager.cls, List.cls, tstListManager.bas
So the ListManager.cls is this
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "ListManager"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private mdic As Object
Public Sub Initialise(ByVal vLists As Variant)
Set mdic = VBA.CreateObject("Scripting.Dictionary")
Dim vListLoop As Variant
For Each vListLoop In vLists
Dim oList As List
Set oList = New List
oList.Initialise vListLoop, ""
mdic.Add mdic.Count, oList
Next
End Sub
Public Function WeaveSort() As Variant
Dim dicReturn As Object
Set dicReturn = VBA.CreateObject("Scripting.Dictionary")
Dim oNextList As List
Set oNextList = Me.WhichListHasLeastProgress
While oNextList.PercentageDone <= 1
Dim vListItem As Variant
vListItem = oNextList.GetListItem
dicReturn.Add dicReturn.Count, vListItem
oNextList.MoveNext
Set oNextList = Me.WhichListHasLeastProgress
Wend
Dim vItems As Variant
vItems = dicReturn.Items
'I don't like this bit
ReDim vRet(1 To dicReturn.Count, 1 To 1)
Dim lLoop As Long
For lLoop = 0 To dicReturn.Count - 1
vRet(lLoop + 1, 1) = vItems(lLoop)
Next lLoop
WeaveSort = vRet
End Function
Public Function WhichListHasLeastProgress() As List
Dim vKeyLoop As Variant
Dim oListLoop As List
Dim oLeastProgress As List
For Each vKeyLoop In mdic.keys
Set oListLoop = mdic.Item(vKeyLoop)
If oLeastProgress Is Nothing Then
'nothing to compare yet
Set oLeastProgress = oListLoop
Else
If oListLoop.PercentageDone < oLeastProgress.PercentageDone Then
'definitely take this new candidate
Set oLeastProgress = oListLoop
ElseIf oListLoop.PercentageDone = oLeastProgress.PercentageDone And oListLoop.Size > oListLoop.Size Then
'close thing, both showing equal progress but we should give it to the one with the bigger "queue"
Set oLeastProgress = oListLoop
Else
'no swap
End If
End If
Next
'return the answer
Set WhichListHasLeastProgress = oLeastProgress
End Function
and the List.cls file is
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "List"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private mvList As Variant
Private mlCount As Long
Private mlCursor As Long
Private mvName As Variant
Public Function Initialise(ByRef vList As Variant, ByVal vName As Variant)
Debug.Assert TypeName(vList(1, 1)) <> "" ' this will break unless you specify a 2d array
Debug.Assert LBound(vList, 1) = 1 ' this ensure you got it from a sheet
mvList = vList
mlCount = UBound(mvList)
mlCursor = 1
mvName = vName
End Function
Public Function GetListItem()
GetListItem = mvList(mlCursor, 1)
End Function
Public Function Name() As Variant
Name = mvName
End Function
Public Function MoveNext() As Boolean
mlCursor = mlCursor + 1
MoveNext = (mlCursor < mlCount)
End Function
Public Function Size() As Long
Size = mlCount
End Function
Public Function PercentageDone() As Double
PercentageDone = mlCursor / mlCount
End Function
The last file is this tstListManager.bas
Attribute VB_Name = "tstListManager"
Option Explicit
Sub test()
Dim oListMan As ListManager
Set oListMan = New ListManager
Dim vLists As Variant
vLists = VBA.Array(ThisWorkbook.Sheets("Source").Range("A1:A3").Value2, _
ThisWorkbook.Sheets("Source").Range("B1:B2").Value2, _
ThisWorkbook.Sheets("Source").Range("C1:C5").Value2)
oListMan.Initialise vLists
Dim vSorted As Variant
vSorted = oListMan.WeaveSort
Dim lTotal As Long
ThisWorkbook.Sheets("Dest").Range("A1").Resize(UBound(vSorted, 1)).Value2 = vSorted
End Sub
Finally, the test data was in A1:A3 B1:B2 C1:C5
You should note I have abstracted away any Excel reading/writing logic and the pure weavesort logic is not cluttered.
Feel free to reject outright. Object orientation can be quite controversial and we think differently. :)
I am attempting to do a VLOOKUP on a different worksheet based on given parameters in the function. I've played around with it for several hours and can not figure out why it is not working. I cut down the code as much as I could to test, but am unable to effectively find a solution. I think it might be an issue of how I am calling the range from the other worksheet for the VLOOKUP. Code is below. Please advice. If I'm unclear about what I'm asking just ask and I will provide feedback. Thank you
Function GraphDataA(cR As String, time As String, aClient As String, tps As String, dat As String)
Dim client As Boolean
Dim day As Boolean
Dim tot As Boolean
Dim dayTotData As Range
Dim dayTotDatas As Worksheet
Set dayTotDatas = ActiveWorkbook.Sheets("DayTot")
Set dayTotData = dayTotDatas.Range("A3:AI168")
client = False
day = False
tot = False
If date = "" Then
GraphDataA = ""
End If
If aClient = "" Then
GraphDataA = ""
End If
If cR = "Client" Then
client = True
End If
If time = "Day" Then
day = True
End If
If tps = "Total" Then
tot = True
End If
If client = True Then
If day = True Then
If tot = True Then
GraphDataA = WorksheetFunction.VLookup(aClient, dayTotData, WorksheetFunction.Match(dat, dayDate, 0) + 8, _
False)
End If
End If
End If
End Function
VLOOKUP() will throw an error if nothing matches. So you need to add error catching code to your function.
You need to modify the function as
Function MyFunction() as Something
On Error Goto ErrorHandler
' Your existing code goes here
Exit Function
ErrorHandler:
MyFunction = -1 ' Or something which indicates that the value isn't found
End Function
You don't appear to be returning any value from your function. Try adding As Variant to the end of the first line like so:
Function GraphDataA(cR As String, time As String, aClient As String, tps As String, dat As String) As Variant