I got a strange issue... my if statement should work but somehow it still doesn't... I can't grasp what is wrong as it seems perfectly right. I can see that the selection is targeting the last row in the A column, and then I'm comparing it to the t_date property in my EURO_USD object which is exactly the same string as in Column("A").End(xlDown), still, it jumps to the else statement(!). Why?
Code
Option Explicit
Private Sub run() ' run the whole operation
Dim HTTP_Req As Object: Set HTTP_Req = New HTTP_Req
Dim EURO_USD As Object: Set EURO_USD = New EURO_USD
Sheets("EURO_USD").Columns("A").End(xlDown).Select
If Selection = EURO_USD.t_date Then
Debug.Print "Date already exist"
Else
Sheets("EURO_USD").Columns("A").End(xlDown).Offset(1, 0) = EURO_USD.t_date
End If
End Sub
EURO_USD Class below
Sub fetch() ' get the function o the ECB URL
Dim xDOM_nodeList As MSXML2.IXMLDOMNodeList
Dim xDom As MSXML2.DOMDocument60
Set xDom = New MSXML2.DOMDocument60
xDom.async = False
xDom.Load "http://www.ecb.europa.eu/stats/eurofxref/eurofxref-daily.xml"
Do Until xDom.readyState = READYSTATE_COMPLETE
DoEvents
Loop
xDom.setProperty "SelectionNamespaces", "xmlns:f='http://www.ecb.int/vocabulary/2002-08-01/eurofxref' xmlns:c='http://www.gesmes.org/xml/2002-08-01'"
Set xDOM_nodeList = xDom.SelectNodes("//f:Cube[#currency='USD']")
Curr_ticker = Val(xDOM_nodeList.Item(0).Attributes(1).text)
Set xDOM_nodeList = xDom.SelectNodes("//f:Cube[#time]")
Curr_date = xDOM_nodeList.Item(0).Attributes(0).text
End Sub
Public Property Get ticker()
If Curr_ticker = 0 Then
Call fetch
End If
ticker = Curr_ticker
End Property
Public Property Get t_date()
If Curr_date = "" Then
Call fetch
End If
t_date = Curr_date
End Property
Remove ":"
If Selection = EURO_USD.t_date Then
Debug.Print "Date already exist"
Else
Sheets("EURO_USD").Columns("A").End(xlDown).Offset(1, 0) = EURO_USD.t_date
End If
From Rory
Your t_Date property is returning a string - what is in the cell? A real date value? Is it formatted the same as the t_Date?
Using function datevalue solved the issue.
Related
Does anyone know a method to sort Visio pages alphabetically using VBA?
I looked to see if a method such as vzdVisioDocument.Pages.Sort exists, but found nothing in documentation or through internet searches.
Do I need to write my own sorting function using the Application.ActiveDocument.Pages.ItemU("Page Name").Index property? That seems to be the method suggested by recording a macro of the action.
So that wasn't as painful as expected. With vzdVisioDocument as an already defined Visio.Document:
' Make a collection of titles to iterate through
Dim colPageTitles As Collection
Set colPageTitles = New Collection
Dim intPageCounter As Integer
For intPageCounter = 1 To vzdVisioDocument.Pages.Count
colPageTitles.Add vzdVisioDocument.Pages.Item(intPageCounter).Name
Next intPageCounter
' For each title in the collection, iterate through pages and find the appropriate new index
Dim intPageIndex As Integer
Dim varPageTitle As Variant
For Each varPageTitle In colPageTitles
For intPageIndex = 1 To vzdVisioDocument.Pages.Count
' Check to see if the title comes before the index's current page title
If StrComp(varPageTitle, vzdVisioDocument.Pages.Item(intPageIndex).Name) < 0 Then
' If so, set the new page index
vzdVisioDocument.Pages.ItemU(varPageTitle).Index = intPageIndex
Exit For
End If
Next intPageIndex
Next varPageTitle
' Clean up
Set colPageTitles = Nothing
I mentioned this in another comment, but when I made some test pages, it was always shuffling the pages around when I ran it because I the way that this is implemented, I don't believe that Exit For should be in there.
I also swapped the comparison to StrCompare due to personal preference along with the order of the for loops.
Sub PageSort()
Dim titlesColl As Collection
Set titlesColl = New Collection
Dim i As Long
For i = 1 To ActiveDocument.Pages.Count
titlesColl.Add ActiveDocument.Pages.Item(i).Name
Next i
Dim title As Variant
For i = 1 To ActiveDocument.Pages.Count
For Each title In titlesColl
If StrComp(ActiveDocument.Pages.Item(i).Name, title, vbTextCompare) < 0 Then
ActiveDocument.Pages.Item(title).index = i
End If
Next title
Next i
Set titlesColl = Nothing
End Sub
Private Sub reorderPages()
Dim PageNameU() As String
Dim isBackgroundPage As Boolean
Dim vsoPage As Visio.Page
Dim vsoCellObj As Visio.Cell
'// Get All Pages
Dim i As Integer
For Each vsoPage In ActiveDocument.Pages
i = i + 1
ReDim Preserve PageNameU(i)
PageNameU(i) = vsoPage.NameU
Next vsoPage
For i = 1 To UBound(PageNameU)
Set vsoPage = vsoPages.ItemU(PageNameU(i))
Set vsoCellObj = vsoPage.PageSheet.Cells("UIVisibility")
isBackgroundPage = vsoPage.Background
'// Make foreground page to set page index
If isBackgroundPage = True Then
vsoCellObj.FormulaU = visUIVNormal
vsoPage.Background = False
End If
vsoPage.Index = NumNonAppSysPages + i
'// Set to background page
If isBackgroundPage = True Then
vsoCellObj.FormulaU = visUIVHidden
vsoPage.Background = True
End If
Next i
End Sub
I have a sub that creates a Collection and adds Collections inside it. But I get an Wrong number of arguments or invalid property assignment error when adding a first collection in the loop:
Sub testState()
Dim stateCopy As State
Set stateCopy = New State
stateCopy.setStateName="some name"
stateCopy.storeBudgetWorkbooks
stateCopy.storeBudgetDatas 'error on this line
End Sub
Sub storeBudgetDatas() 'inside a class named State
...
Dim year As Integer
Dim i As Integer
i = 1
For year = 2014 To 2017
Set budgetWorkbook =
ExcelApp.Application.Workbooks.Open(budgetWorkbooks(i))
MsgBox ("still here") 'this message appears
allBudgetItems.Add getBudgetData(budgetWorkbook, year) 'this line is likely to cause problems
MsgBox ("and here") 'this message doesn't appear
budgetWorkbook.Close
i = i + 1
Next
End Sub
Function getBudgetData(budgetWorkbook As Workbook, year As Integer)
...
Dim budgetItems As Collection
Set budgetItems = getBudgetItems(year)
... 'setting attributes
getBudgetData = budgetItems(year)
End Function
Function getBudgetItems(year As Integer)
...
Dim resultCollection As Collection
Set resultCollection = New Collection
Dim itemCopy As Item
Dim i As Integer
For i = LBound(budgetItemNames) To UBound(budgetItemNames)
Set itemCopy = New Item
... 'setting attributes
resultCollection.Add itemCopy
Next
Set getBudgetItems = resultCollection
End Function
I'm not sure what's wrong here. getBudgetItems returns a collection. getBudgetData returns a collection as well. I tried adding/removing parenthesis but to no avail.
Figured it out. There should have been Set getBudgetData = budgetItems(year) instead of getBudgetData = budgetItems(year).
Since you haven't shown us all the relevant parts of your code, the best I can do is guess you're missing a Set:
Function getBudgetData(budgetWorkbook As Workbook, year As Integer)
...
Dim budgetItems As Collection
Set budgetItems = getBudgetItems(year)
... 'setting attributes
Set getBudgetData = budgetItems(year) ' Need Set here
End Function
Maybe this question is simple, but I couldn't find an answer by googling.
So, I've got my class WSheet. I initialize array of objects of this class in my program:
ReDim WSheets(twb.Sheets.Count)
For i = 0 To UBound(WSheets)
Set WSheets(i) = New WSheet
Next i
And then, I try to read new values and sort them by insertion sort:
For i = twb.Sheets.Count To 2 Step -1
flag = False
tsName = twb.Sheets(i).Name
twb.Sheets(i).Delete
twb.Save
CurShW = curLen - FileLen(TempFName)
curLen = FileLen(TempFName)
For j = UBound(WSheets) To 2 Step -1
If WSheets(j - 1).Weight < CurShW Then
Set WSheets(j) = WSheets(j - 1)
Else
WSheets(j).SetName (tsName)
WSheets(j).SetWeight (CurShW)
flag = True
Exit For
End If
Next j
If Not flag Then
Set WSheets(1) = New WSheet
WSheets(1).SetName (tsName)
WSheets(1).SetWeight (CurShW)
flag = False
End If
Next i
So, the problem: after I set WSheets(j) = WSheets(j - 1), wsheets(j - 1) starts to contain link to wsheets(j), so, when I change wsheets(j), Wsheets (j - 1) changes too.
Please, share how to make absolute equation in this sample?
Thank you!
PS code in WSheet class
Dim SName As String 'Name of sheet
Dim SWeight As Long 'Weight of sheet in bytes
Dim blocks() As Long 'Weights of blocks in sheet in bytes
Public Function Weight() As Long
Weight = SWeight
End Function
Public Sub SetWeight(ByVal sw As Long)
SWeight = sw
End Sub
Public Function Name() As String
Name = SName
End Function
Public Sub SetName(ByVal nm As String)
SName = nm
End Sub
edited to turn the function into a Class method
You must clone the WSheet object instead of referencing it
For instance you could add a Clone() method to your WSheet class
Function Clone() As WSheet
Dim newWSheet As WSheet
Set newWSheet = New WSheet
newWSheet.SetName SName
newWSheet.SetWeight SWeight
Set Clone = newWSheet
End Function
Then in your main code change:
Set WSheets(j) = WSheets(j - 1)
To:
Set WSheets(j) = WSheets(j - 1).Clone
Can any one explain me to get the object entites count of the layer
using vba code acad
I think You should use SelectionSets
Public Sub SelsetByLayer()
Dim ss As AcadSelectionSet
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
FilterType(0) = 8 ' DXF code of Layer property
For I = 0 To ThisDrawing.Layers.Count
' ThisDrawing.SelectionSets.Item(0).Delete
Set ss = ThisDrawing.SelectionSets.Add("test") ' You need to ensure if such selection set not exist yet .
FilterData(0) = ThisDrawing.Layers.Item(I).Name
ss.Select acSelectionSetAll, , , FilterType, FilterData
Next
End Sub
Further to the original answer, about using selection sets.
Here it is slightly modified:
Public Sub SelsetByLayer()
Dim ss As AcadSelectionSet
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
FilterType(0) = 8 ' DXF code of Layer property
For I = 0 To ThisDrawing.Layers.Count
Set ss = CreateSelectionSet("test")
FilterData(0) = ThisDrawing.Layers.Item(I).Name
ss.Select acSelectionSetAll, , , FilterType, FilterData
Next
End Sub
Public Function CreateSelectionSet(SelName As String) As AcadSelectionSet
On Error Resume Next
' Create a new selection set
' Delete any existing selection set with the specified name
With ThisDrawing
Set CreateSelectionSet = .SelectionSets.Add(SelName)
If (Err.Number <> 0) Then
Err.Clear
.SelectionSets.Item(SelName).Delete
Set CreateSelectionSet = .SelectionSets.Add(SelName)
End If
End With
End Function
I have added in the missing method for managing the deletion of existing selection set.
ss.Count will have the number of entities found. But please bear in mind that you may have layers frozen off etc. in the drawing and I think these will be excluded from the totals.
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