I have a sub with a variant variable set up that changes its type midway for now apparent reason.
I have the variables declared at the beginning of the procedure:
Dim acsp As Variant
Dim oldmaster As Variant
Dim acontacts As Variant
Dim avp As Variant
Dim acctst As Variant
Dim ashipto As Variant
Dim abillto As Variant
Dim found, found1, found2 As Boolean
acsp = Sheet6.UsedRange.Value2
acontacts = Sheet5.UsedRange.Value2
avp = Sheet9.UsedRange.Value2
acctst = Sheet20.UsedRange.Value2
ashipto = Sheet11.UsedRange.Value
abillto = Sheet15.UsedRange.Value
The code runs and based on an IF condition it might call this code (inside the same sub):
c = UBound(acsp) + 1
shipto = Trim(UCase(acctst(aa, 27)))
billto = Trim(UCase(acctst(aa, 38)))
shiptofound = False
For shiptorow = 2 To UBound(ashipto)
ashipto1 = Trim(UCase(ashipto(shiptorow, 2)))
If ashipto1 = shipto Then
shiptofound = True
Exit For
End If
Next shiptorow
Up until the shiptofound=False line the abillto variant is shown as variant/variant (1 to 677, 1 to 18) which is correct.
But as soon it runs the line For shiptorow = 2 To UBound(ashipto) then the abillto variant changes to a type variant/long with a value of 2?
At no point prior to this code abillto is used in the code.
Why does VBA do this?
Related
I am writing a user-defined function in excel vba. So this new function:
takes 4 input value
some calculation to generate into 8 numbers. ( 2 arrays - each array has 4 numbers)
do a chisquare test
return 1 output value
Code:
Sub test()
Dim A, B, C, D As Variant
A = 33
B = 710
C = 54
D = 656
'Observed Value
Dim O_A As Variant
Dim O_B As Variant
Dim O_V As Variant
Dim O_D As Variant
'Define Observer Value
O_C_A = 'Some Calucation'
O_C_B = 'Some Calucation'
O_T_C = 'Some Calucation'
O_T_C = 'Some Calucation'
'Expected Value
Dim E_C_A As Variant
Dim E_C_B As Variant
Dim E_T_C As Variant
Dim E_T_D As Variant
'Define Expected Value
E_C_A = 'Some Calucation'
E_C_B = 'Some Calucation'
E_T_C = 'Some Calucation'
E_T_D = 'Some Calucation'
'Create array(2x2)
Dim Chi_square_result As Variant
Dim my_array(1, 1)
my_array(0, 0) = O_C_Mesaurement
my_array(0, 1) = O_C_Balance
my_array(1, 0) = O_T_Measurement
my_array(1, 1) = O_T_Balance
Dim my_array2(1, 1)
my_array2(0, 0) = E_C_Mesaurement
my_array2(0, 1) = E_C_Balance
my_array2(1, 0) = E_T_Measurement
my_array2(1, 1) = E_T_Balance
'Create a chi square test formula'
Dim formula(1 To 5) As String
formula(1) = "CHITEST("
formula(2) = my_array
formula(3) = ","
formula(4) = my_array2
formula(5) = ")"
'Chi Square
Chi_square_result = evaluate(Join(formula, ""))
end sub
It gives a runtime error '13', saving type mismatch. This is because of the concatenation of the formula.
If you are writing a function, you have your format wrong.
Function Chi_square_result(A as Long, B as Long, C as Long, D as Long) as Double
'All your manipulations here
Chi_square_result = (Your math equation)
End Function
You also never defined my_array1, I am assuming it is supposed to be where you typed 'my_array'. I also do not think Join is your best bet. You are trying to do an awful lot of array manipulation, and I think your dimensions are getting you. It would be better to do it in a more straight forward way.
The evaluate is expecting worksheet cell ranges. Use the Excel Application object or WorksheetFunction object to compute the function within VBA.
This proofs out.
Dim dbl As Double
Dim my_array1(1, 1)
my_array1(0, 0) = 1
my_array1(0, 1) = 2
my_array1(1, 0) = 3
my_array1(1, 1) = 4
Dim my_array2(1, 1)
my_array2(0, 0) = 2
my_array2(0, 1) = 3
my_array2(1, 0) = 4
my_array2(1, 1) = 5
dbl = Application.ChiTest(my_array1, my_array2)
Debug.Print dbl
Result from the VBE's Immediate window: 0.257280177154182.
Whenever i am trying to debug or run the program and if it encounters error, the VBE (Autocad) doesn't display the line where the error is, unlike in other IDEs, it used to come at that line and highlight with yellow color. Also, the scroll doesn't work. I know i should install plugins but i am unable to help myself.
Option Explicit
Sub Test()
'Declarations
'Opened Document
Dim acDocu As AcadDocument
Set acDocu = ThisDrawing.Application.ActiveDocument
'Select on screen
Dim acSelectionSet As AcadSelectionSet
Set acSelectionSet = ThisDrawing.SelectionSets.Add("SjjEffffT")
acSelectionSet.SelectOnScreen
'Manipulating in loops for finding group names having objects selected
Dim entity As AcadEntity
Dim entityhandle() As String
Dim Grp As AcadGroup
Dim groupname() As String
Dim i As Integer
i = 0
Dim j As Integer
j = 0
Dim temp As Integer
temp = 0
Dim GrpEnt As AcadEntity
Dim grpenthandle As String
Dim entity_count As Integer
'Dim entity_array As Variant
entity_count = acSelectionSet.Count
ReDim entityhandle(entity_count)
ReDim groupname(entity_count)
For Each entity In acSelectionSet
'entity_array = entity
entityhandle(i) = entity.Handle
For Each Grp In ThisDrawing.groups
For Each GrpEnt In Grp
grpenthandle = GrpEnt.Handle
If entityhandle(i) = grpenthandle Then
If temp = 0 Then
groupname(j) = Grp.Name
Debug.Print "Group in selection:" & groupname(j)
j = j + 1
End If
End If
temp = temp + 1
Next
temp = 0
Next
i = i + 1
Next
'Copying the objects and pasting into new drawing
Dim acDocto As AcadDocument
Dim file_name As String
'file_name = InputBox("Enter the file name along with full path and extension")
file_name = "D:\PI_Tool_files_3223\D00440023new.DWG"
Set acDocto = Documents.Open(file_name)
Dim acObject As AcadObject
Dim retvalue As Variant
retvalue = acDocu.CopyObjects(entityhandle, acDocto.ModelSpace)
acSelectionSet.Delete
End Sub
The code is written above. But i think the problem is with the add-in as i can't debug.
The VBA IDE is pretty old (1998) and it has limited debugging abilities. You should stop using this, it's an obsolete technology, not actively supported by Microsoft/Autodesk anymore.
For some errors, it is not able to locate the line where the error occurred, and you're left with obscure error codes and useless messages.
Have you tried setting a breakpoint at the first possible line? (Set acDocu = ThisDrawing.Application.ActiveDocument)
Then step through to see the offending object/property/method.
It doesn't always work.
Can you load the code into a module, instead of "ThisDrawing", then debug?
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 totally new in VBA and coding in general, am trying to get data from cells from the same workbook (get framework path ...) and then to start application (QTP) and run tests.
I am getting this error when trying to get values entered in excel cells:
Run Time Error '424' object required
I believe I am missing some basic rules but I appreciate your help. Please see below the part of code in question:
Option Explicit
Private Sub RunTest_Click()
Dim envFrmwrkPath As Range
Dim ApplicationName As Range
Dim TestIterationName As Range
'Dim wb As Workbook
'Dim Batch1 As Worksheets
Dim objEnvVarXML, objfso, app As Object
Dim i, Msgarea
Set envFrmwrkPath = ActiveSheet.Range("D6").Value ' error displayed here
Set ApplicationName = ActiveSheet.Range("D4").Value
Set TestIterationName = ActiveSheet.Range("D8").Value
The first code line, Option Explicit means (in simple terms) that all of your variables have to be explicitly declared by Dim statements. They can be any type, including object, integer, string, or even a variant.
This line: Dim envFrmwrkPath As Range is declaring the variable envFrmwrkPath of type Range. This means that you can only set it to a range.
This line: Set envFrmwrkPath = ActiveSheet.Range("D6").Value is attempting to set the Range type variable to a specific Value that is in cell D6. This could be a integer or a string for example (depends on what you have in that cell) but it's not a range.
I'm assuming you want the value stored in a variable. Try something like this:
Dim MyVariableName As Integer
MyVariableName = ActiveSheet.Range("D6").Value
This assumes you have a number (like 5) in cell D6. Now your variable will have the value.
For simplicity sake of learning, you can remove or comment out the Option Explicit line and VBA will try to determine the type of variables at run time.
Try this to get through this part of your code
Dim envFrmwrkPath As String
Dim ApplicationName As String
Dim TestIterationName As String
Simply remove the .value from your code.
Set envFrmwrkPath = ActiveSheet.Range("D6").Value
instead of this, use:
Set envFrmwrkPath = ActiveSheet.Range("D6")
You have two options,
-If you want the value:
Dim MyValue as Variant ' or string/date/long/...
MyValue = ThisWorkbook.Sheets(1).Range("A1").Value
-if you want the cell object:
Dim oCell as Range ' or object (but then you'll miss out on intellisense), and both can also contain more than one cell.
Set oCell = ThisWorkbook.Sheets(1).Range("A1")
Private Sub CommandButton1_Click()
Workbooks("Textfile_Receiving").Sheets("menu").Range("g1").Value = PROV.Text
Workbooks("Textfile_Receiving").Sheets("menu").Range("g2").Value = MUN.Text
Workbooks("Textfile_Receiving").Sheets("menu").Range("g3").Value = CAT.Text
Workbooks("Textfile_Receiving").Sheets("menu").Range("g4").Value = Label5.Caption
Me.Hide
Run "filename"
End Sub
Private Sub MUN_Change()
Dim r As Integer
r = 2
While Range("m" & CStr(r)).Value <> ""
If Range("m" & CStr(r)).Value = MUN.Text Then
Label5.Caption = Range("n" & CStr(r)).Value
End If
r = r + 1
Wend
End Sub
Private Sub PROV_Change()
If PROV.Text = "LAGUNA" Then
MUN.Text = ""
MUN.RowSource = "Menu!M26:M56"
ElseIf PROV.Text = "CAVITE" Then
MUN.Text = ""
MUN.RowSource = "Menu!M2:M25"
ElseIf PROV.Text = "QUEZON" Then
MUN.Text = ""
MUN.RowSource = "Menu!M57:M97"
End If
End Sub
I've been trying to resurrect an existing drawing check macro, and want to find the co-ordinates of any note blocks on each sheet. I've been modifying code found here using the GetAttachPos method from this page, but for some reason any co-ordinates returned come back around (8.80942311664557E-03,2.24429295226372E-03).
I'm thinking that the problem is that I've missed a reference somewhere, but I'm not sure where. Although it's definitely finding the notes since it passes back their text. Anyway, here's the method I'm testing at the moment:
Sub Main()
Dim swApp As SldWorks.SldWorks
Set swApp = CreateObject("SldWorks.Application")
Dim NoteNumbersText As String
Dim NoteText As String
Dim NumberofSheets As Integer ' The number of sheets in this drawing
Dim NamesOfSheets As Variant ' Names of all of the sheets
Dim sheet As SldWorks.sheet ' The Sheet that we are working on
Dim LocalView As SldWorks.View ' Current View that we are looking at
Dim LocalNote As SldWorks.Note ' Current Note that we are looking at
Dim TextFormat As SldWorks.TextFormat ' Current text format object of a note
Dim Xpos As Double ' X, Y Z position on the drawing in Metres
Dim Ypos As Double
Dim SizeOfSheet As Double
Dim x As Integer ' general Loop Variables
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim vPosition As Variant
Dim vNote As Variant ' Single note
Dim swNote As SldWorks.Note ' Single Solidworks Note Object
Dim ThisAnnotation As SldWorks.Annotation
Dim swBlockInst As SldWorks.SketchBlockInstance
Dim swBlockDef As SldWorks.SketchBlockDefinition
Dim NumofNotes As Integer
Dim ArrayOfNotes() As NoteInfo
Dim LocalDrawingDoc As SldWorks.DrawingDoc ' Declared as an Object so that non Drawings can be detected!
Dim LocalPart As SldWorks.ModelDoc2 ' Declared as an Object so that non Drawings can be detected!
Dim strShtProp As Variant
Set LocalDrawingDoc = swApp.ActiveDoc
Set LocalPart = swApp.ActiveDoc
ReDim ArrayOfNotes(0)
' Get the sheet names and the number of them
NamesOfSheets = LocalDrawingDoc.GetSheetNames()
NumberofSheets = LocalDrawingDoc.GetSheetCount
' store this sheet name
Set sheet = LocalDrawingDoc.GetCurrentSheet()
strShtProp = sheet.GetProperties() ' get the sheet properties use much later for converting position into ref
SizeOfSheet = strShtProp(5)
Dim SwSketchMgr As SldWorks.SketchManager
Set SwSketchMgr = LocalDrawingDoc.SketchManager
Dim i As Integer
Dim vBlockDef As Variant
Dim vBlockInst As Variant
Dim strReturn As String
' Dim bret As Boolean
vBlockDef = SwSketchMgr.GetSketchBlockDefinitions
For x = NumberofSheets - 1 To 0 Step -1
If LocalDrawingDoc.GetCurrentSheet.GetName <> NamesOfSheets(x) Then LocalDrawingDoc.ActivateSheet NamesOfSheets(x)
Set LocalView = LocalDrawingDoc.GetFirstView
While Not LocalView Is Nothing
If Not IsEmpty(vBlockDef) Then
For i = 0 To UBound(vBlockDef)
Set swBlockDef = vBlockDef(i)
vBlockInst = swBlockDef.GetInstances
vNote = swBlockDef.GetNotes
If Not IsEmpty(vNote) Then
For j = 0 To UBound(vNote)
Set swNote = vNote(j)
NoteNumbersText = Trim(swNote.GetText)
If Left(NoteNumbersText, 1) = "n" And Len(NoteNumbersText) > 1 And Len(NoteNumbersText) < 4 Then
Set ThisAnnotation = swNote.GetAnnotation
'vPosition = swNote.GetAttachPos
vPosition = ThisAnnotation.GetPosition
Xpos = vPosition(0)
Ypos = vPosition(1)
Debug.Print ("Note " & NoteNumbersText & ": " & Xpos & "," & Ypos)
End If
Next j
End If
Next i
End If
Set LocalView = LocalView.GetNextView
Wend
Next x
End Sub
Turns out that SolidWorks is set up to return positions of blocks relative to the drawing view on which they're placed. Calling GetXForm for the view which they are placed on then provides a way of calculating the absolute position of each note.