vbscript reading Cisco switch interfaces - regex

Trying to create a script that will send a 'sh run | b interface' to a Cisco switch. Write the output to an array. Split that array with a vbcr so each line of the config is in a sep elemant of the array.
I have tried to skin the cat many ways and still I am struggling.
Logic in English:
Send command to Cisco device
Capture the output to an array
define expected lines 'This are lines that are required under each 'interface' of the switch
Match the 'interface' name and corresponding number and write it to a file.
Check under that interface for the specific lines in the expected
If it finds it, write the line & ", YES"
If it does not find it, write the line & ", NO"
Keep doing this until you do not find any more '^interface\s[FG][a-z].+'
Output should look like this:
Interface GigabitEthernet 0/2
spanning-tree portfast, YES
This is the sample code that is failing:
'These are the expected line (not being compared in the script below but is my intention to have it compare the matched elements)
Dim vExpectedINT(4)
vExpectedINT(0) = "spanning-tree portfast"
vExpectedINT(1) = "switchport access vlan 17"
vExpectedINT(2) = "switchport mode access"
vExpectedINT(3) = "ip mtu 1400"
'objStream.Write "######################################################### " & vbcrlf
'objStream.Write "# I N T E R F A C E # " & vbcrlf
'objStream.Write "######################################################### " & vbcrlf
nCount = 0
vConfigLines = Split(strResultsINT, vbcr)
Set re = new RegExp
re.Global = False
re.IgnoreCase = True
re.Multiline = False
re.Pattern = "^interface [FG]"
' Regex Ex Definition
Set re2 = new RegExp
re2.Global = False
re2.IgnoreCase = True
re2.Multiline = False
re2.Pattern = "\sspanning-tree\sportfast"
' Regex Ex Definition
Set re3 = new RegExp
re3.Global = False
re3.IgnoreCase = True
re3.Multiline = False
re3.Pattern = "ip\smtu\s1400"
Set re4 = new RegExp
re4.Global = False
re4.IgnoreCase = True
re4.Multiline = False
re4.Pattern = "!"
' Compares the information
x = 1
Do While x <= Ubound(vConfigLines) - 1 do
MsgBox chr(34) & strLine & chr(34)
If re.Test(vConfigLines(x)) Then
' Write data to not expected section
x=x+1
do
If ! re4.Test(vConfigLines(x)) Then
MsgBox vConfigLines(x)
'objStream.Write vConfigLines(x) & vbcr
elseif re2.Test(vConfigLines(x)) Then
MsgBox vConfigLines(x)
elseif re3.Test(vConfigLines(x)) Then
MsgBox vConfigLines(x)
else
exit do
end if
x=x+1
loop
end IF
End If
Loop
This is a sample of the vConfigLines output:
There could be 48+ port per switch.
interface FastEthernet1/0/1
switchport access vlan 127
switchport mode access
switchport voice vlan 210
srr-queue bandwidth share 10 10 60 20
srr-queue bandwidth shape 0 3 0 0
priority-queue out
mls qos trust cos
auto qos voip trust
spanning-tree portfast
!
interface FastEthernet1/0/2
switchport access vlan 127
switchport mode access
switchport voice vlan 210
srr-queue bandwidth share 10 10 60 20
srr-queue bandwidth shape 0 3 0 0
priority-queue out
mls qos trust cos
auto qos voip trust
spanning-tree portfast
!
interface FastEthernet1/0/3
switchport access vlan 127
switchport mode access
switchport voice vlan 210
srr-queue bandwidth share 10 10 60 20
srr-queue bandwidth shape 0 3 0 0
priority-queue out
mls qos trust cos
auto qos voip trust
spanning-tree portfast

When facing a difficult and complex task, just follow these rules:
Divide the task in independently solvable subproblems
getting the info from Cisco
processing the resulting file
gather interesting info
output
Concentrate on the difficult subtask(s)
processing the resulting file
Solve a simplified but generalized version of (each) subtask using handmade data
for easy testing
You have items and are interested in whether they (don't) have given properties
Data to play with:
Item 0 (both props)
prop_a
prop_b
!
Item 1 (just b)
prop_b
!
Item 2 (a only)
prop_a
!
Item 3 (none)
!
Item 4 (irrelevant prop)
prop_c
!
Item 5 (Richy)
prop_c
prop_b
prop_a
!
Item 6 (Junky)
junk
prop_b
whatever
!
#Item 7 (Nasty)
# prop_a_like_but_not_prop_a
# prop_b
#!
Keep it simple
don't do more than absolutely necessary
don't use variables/components you can do without
So let's start:
You have to deal with a text file (lines). So don't do more than
Dim tsIn : Set tsIn = goFS.OpenTextFile("..\data\TheProblem.txt")
Dim sLine
Do Until tsIn.AtEndOfStream
sLine = Trim(tsIn.ReadLine())
If "" <> sLine Then
End If
Loop
tsIn.Close
90 % of the code using Split on .ReadAll is just fat. Yes, it's Do Until tsIn.AtEndOfStream and not Do While tsIn.AtEndOfStream = False. No Set tsIn = Nothing,
please.
The data is organized in blocks (Item n ... !), so make sure you
recognize the parts and know what to do when finding them:
Dim tsIn : Set tsIn = goFS.OpenTextFile("..\data\TheProblem.txt")
Dim sItem : sItem = "Item"
Dim sEnd : sEnd = "!"
Dim sLine
Do Until tsIn.AtEndOfStream
sLine = Trim(tsIn.ReadLine())
If "" <> sLine Then
Select Case True
Case 1 = Instr(sLine, sItem)
WScript.Echo "Begin, note item (name)"
Case 1 = Instr(sLine, sEnd)
WScript.Echo "End, output info"
WScript.Echo "----------"
Case Else
WScript.Echo "Middle, gather info"
End Select
End If
Loop
tsIn.Close
output:
Begin, note item (name)
Middle, gather info
Middle, gather info
End, output info
----------
Begin, note item (name)
Middle, gather info
End, output info
----------
...
For each item the output should be:
name, property, yes|no
The easiest way to do that is
WScript.Echo Join(aData, ", ")
Joining beats concatenation, especially if you want to set/manipulate the
parts independently and/or to pre-set some of them in the beginning.
Dim aData : aData = Array( _
Array( "Item?", "prop_a", "NO") _
, Array( "Item?", "prop_b", "NO") _
)
Dim sLine, aTmp, nIdx
Do Until tsIn.AtEndOfStream
sLine = Trim(tsIn.ReadLine())
If "" <> sLine Then
Select Case True
Case 1 = Instr(sLine, sItem)
aTmp = aData
For nIdx = 0 To UBound(aTmp)
aTmp(nIdx)(0) = sLine
Next
Case 1 = Instr(sLine, sEnd)
For nIdx = 0 To UBound(aTmp)
WScript.Echo Join(aTmp(nIdx), ", ")
Next
WScript.Echo "----------"
Case Else
WScript.Echo "Middle, gather info"
End Select
End If
Loop
tsIn.Close
The output
...
Item 3 (none), prop_a, NO
Item 3 (none), prop_b, NO
...
shows that by setting sensible defaults (NO), this version of the script
deals correctly with items having none of the interesting properties.
So lets tackle the middle/Case Else part:
Case Else
For nIdx = 0 To UBound(aTmp)
If 1 = Instr(sLine, aTmp(nIdx)(1)) Then
aTmp(nIdx)(2) = "YES"
Exit For
End If
Next
output now:
Item 0 (both props), prop_a, YES
Item 0 (both props), prop_b, YES
----------
Item 1 (just b), prop_a, NO
Item 1 (just b), prop_b, YES
----------
Item 2 (a only), prop_a, YES
Item 2 (a only), prop_b, NO
----------
Item 3 (none), prop_a, NO
Item 3 (none), prop_b, NO
----------
Item 4 (irrelevant prop), prop_a, NO
Item 4 (irrelevant prop), prop_b, NO
----------
Item 5 (Richy), prop_a, YES
Item 5 (Richy), prop_b, YES
----------
Item 6 (Junky), prop_a, NO
Item 6 (Junky), prop_b, YES
----------
But what about Nasty:
#Item 7 (Nasty)
# prop_a_like_but_not_prop_a
# prop_b
#!
The simple Instr() will fail, if one property name is a prefix of
another. To prove that starting simple and add complexity later
is good strategy:
Dim sFSpec : sFSpec = "..\data\TheProblem.txt"
WScript.Echo goFS.OpenTextFile(sFSpec).ReadAll
Dim tsIn : Set tsIn = goFS.OpenTextFile(sFSpec)
Dim sItem : sItem = "Item"
Dim sEnd : sEnd = "!"
Dim aData : aData = Array( _
Array( "Item?", "prop_a", "NO") _
, Array( "Item?", "prop_b", "NO") _
)
Dim aRe : aRe = Array(New RegExp, New RegExp)
Dim nIdx
For nIdx = 0 To UBound(aRe)
aRe(nIdx).Pattern = "^" & aData(nIdx)(1) & "$"
Next
Dim sLine, aTmp
Do Until tsIn.AtEndOfStream
sLine = Trim(tsIn.ReadLine())
If "" <> sLine Then
Select Case True
Case 1 = Instr(sLine, sItem)
aTmp = aData
For nIdx = 0 To UBound(aTmp)
aTmp(nIdx)(0) = sLine
Next
Case 1 = Instr(sLine, sEnd)
For nIdx = 0 To UBound(aTmp)
WScript.Echo Join(aTmp(nIdx), ", ")
Next
WScript.Echo "----------"
Case Else
For nIdx = 0 To UBound(aTmp)
If aRe(nIdx).Test(sLine) Then
aTmp(nIdx)(2) = "YES"
Exit For
End If
Next
End Select
End If
Loop
tsIn.Close
output:
Item 0 (both props)
prop_a
prop_b
!
Item 1 (just b)
prop_b
!
Item 2 (a only)
prop_a
!
Item 3 (none)
!
Item 4 (irrelevant prop)
prop_c
!
Item 5 (Richy)
prop_c
prop_b
prop_a
!
Item 6 (Junky)
junk
prop_b
whatever
!
Item 7 (Nasty)
prop_a_like_but_not_prop_a
prop_b
!
Item 0 (both props), prop_a, YES
Item 0 (both props), prop_b, YES
----------
Item 1 (just b), prop_a, NO
Item 1 (just b), prop_b, YES
----------
Item 2 (a only), prop_a, YES
Item 2 (a only), prop_b, NO
----------
Item 3 (none), prop_a, NO
Item 3 (none), prop_b, NO
----------
Item 4 (irrelevant prop), prop_a, NO
Item 4 (irrelevant prop), prop_b, NO
----------
Item 5 (Richy), prop_a, YES
Item 5 (Richy), prop_b, YES
----------
Item 6 (Junky), prop_a, NO
Item 6 (Junky), prop_b, YES
----------
Item 7 (Nasty), prop_a, NO
Item 7 (Nasty), prop_b, YES
----------

Related

VB6 - Adding and searching for an item in sorted list - better performance

I need to maintain an old system written in vb6.
Currently in this system there is an sorted list of integers with approximately 1 million items. To locate an item, I use binary search to obtain the shortest response time.
I need to add new items to this list in runtime and these items are added to the end of the list, however the binary search requires that the list is sorted.
Currently the list is a User-Defined Data Types and the ordering is by the Code field
Private Type ProductDetails
ProdID as String
ProdName as String
Code as Double
End Type
The main requirement is the response time to find an item in whatever position it is.
Any idea or tip of this implementation will be very welcome.
thankful
Nadia
Fastest way is with collection:
this is output from test sub:
creating 1.000.000 long product list
**done in 16,6219940185547 seconds**
searching list
fastest way (instant) if you know index (if you have ID)
ID0500000
500000 ID0500000 This is product 500000
**done in 0 seconds**
searching by name (find item 500.000 which is in the middle od list
500000 ID0500000 This is product 500000
**done in 0,425003051757813 seconds**
listing all items that have '12345' in their name
12345 ID0012345 This is product 12345
112345 ID0112345 This is product 112345
123450 ID0123450 This is product 123450
123451 ID0123451 This is product 123451
123452 ID0123452 This is product 123452
123453 ID0123453 This is product 123453
123454 ID0123454 This is product 123454
123455 ID0123455 This is product 123455
123456 ID0123456 This is product 123456
123457 ID0123457 This is product 123457
123458 ID0123458 This is product 123458
123459 ID0123459 This is product 123459
212345 ID0212345 This is product 212345
312345 ID0312345 This is product 312345
412345 ID0412345 This is product 412345
512345 ID0512345 This is product 512345
612345 ID0612345 This is product 612345
712345 ID0712345 This is product 712345
812345 ID0812345 This is product 812345
912345 ID0912345 This is product 912345
**done in 2,05299377441406 seconds**
so, if you load list in memory at the beginning of the app it should search fast enough
'following this code goes in module:
Option Explicit
Private Type ProductDetails
ProdID As String
ProdName As String
Code As Double
End Type
Dim pdList As New Collection
Function genRndNr(nrPlaces) 'must be more then 10
Dim prefix As String
Dim suffix As String
Dim pon As Integer
prefix = Right("0000000000" + CStr(DateDiff("s", "2020-01-01", Now)), 10)
suffix = Space(nrPlaces - 10)
For pon = 1 To Len(suffix)
Randomize
Randomize Rnd * 1000000
Mid(suffix, pon, 1) = CStr(Int(Rnd * 10))
Next
genRndNr = prefix + suffix
End Function
Sub test()
Dim pd As ProductDetails
Dim pdData As Variant
Dim query As String
Dim pon As Long
Dim startT As Long
Debug.Print "creating 1.000.000 long product list"
startT = Timer
For pon = 1 To 1000000
pd.Code = pon
pd.ProdID = "ID" + Right("0000000000" + CStr(pon), 7) 'id= from ID0000001 to ID1000000
pd.ProdName = "This is product " + CStr(pon) 'product name
pdData = Array(pd.Code, pd.ProdID, pd.ProdName) 'create array
pdList.Add pdData, pd.ProdID 'adding array to collection (pd.ID=index)
Next
Debug.Print "done in " + CStr(Timer - startT) + " seconds"
Debug.Print
Debug.Print
Debug.Print "searching list"
startT = Timer
Debug.Print "fastest way (instant) if you know index (if you have ID)"
query = "ID0500000"
pdData = pdList(query)
pd.Code = pdData(0)
pd.ProdID = pdData(1)
pd.ProdName = pdData(2)
Debug.Print query
Debug.Print pd.Code, pd.ProdID, pd.ProdName
Debug.Print "done in " + CStr(Timer - startT) + " seconds"
Debug.Print
Debug.Print
Debug.Print "searching by name (find item 500.000 which is in the middle od list"
startT = Timer
query = "This is product 500000"
For Each pdData In pdList
If query = pdData(2) Then
pd.Code = pdData(0)
pd.ProdID = pdData(1)
pd.ProdName = pdData(2)
Exit For
End If
Next
Debug.Print pd.Code, pd.ProdID, pd.ProdName
Debug.Print "done in " + CStr(Timer - startT) + " seconds"
Debug.Print
Debug.Print
Debug.Print "listing all items that have '12345' in their name"
startT = Timer
query = "*12345*"
For Each pdData In pdList
If pdData(2) Like query Then
pd.Code = pdData(0)
pd.ProdID = pdData(1)
pd.ProdName = pdData(2)
Debug.Print pd.Code, pd.ProdID, pd.ProdName
End If
Next
Debug.Print "done in " + CStr(Timer - startT) + " seconds"
Debug.Print
Debug.Print
'clear pd memory buffer
Set pdList = Nothing
End Sub

Trying to extract values from text -

I am trying to get acc, accel and rx from below text only if accounting value is true.
dataRx: 21916 drx: 1743625
ota: 191791 orx: 74164489
dataDropped: 14 dropped:1134
id: 65535 waitress BE nginxid: 0 kbps: 0.000
accounting: false
drop : 1
rx : 48392 bytes: 483920
id: 65533 waitress BE nginxid: 1 kbps: 0.000
accounting: false
drop : 4
rx : 122914 bytes: 70081939
id: 4232 nginx BE nginxid: 3 kbps: 0.000
accounting: false
drop : 0
rx : 3084 bytes: 94357
id: 10482 server BE nginxid: 4 kbps: 0.000
accounting: false
drop : 0
rx : 15 bytes: 2477
id: 20344 serve BE nginxid: 10 kbps: 62914.560
accounting: true
drop : 2
rx : 2217 bytes: 309637
accel : 482 bytes: 264318
acc :349 bytes: 225181
Below python code gets accounting and accel values using below regex
accounting:\s*((?P<accounting>\S*)[\S\s]*?accel:[\S\s]*?bytes:\s*(?P<accel>\S*)[\S\s]*?)
for match in re.finditer(re_exp, text):
group = match.groupdict()
print group
Output:
{"accounting": false, "accel": 264318}
But, the expected output should be
{"accounting": true, "accel": 264318}
Need help with regex expression. Any help would be greatly appreciated.
Also, is there a regex way to group all the data fields under id?
Thanks
Try this
content = open("acc.txt",'r')
ar = content.read()
import re
getdata = re.findall(r"accounting: (true).+?accel.+?bytes:\s(\d+)",ar,re.S)
print getdata
Try as the follow for group the all data corresponding to their id
content = open("acc.txt",'r')
ar = content.readlines()
arv = []
flag = 0
m = ""
for j in ar:
if("id:"in j):
arv.append(m)
m = ""
flag = 1
if (flag == 1):
m+=j
for j in (arv):
print j
Iterate through lines one by one:
import re
rx = ""
accel = ""
acc = ""
lines = text.split("\n")
for i in range(len(lines)):
line = lines[i]
if line == "accounting: true":
match = re.search(r"rx\s*:\s+(\d*)", lines[i+2])
if match:
rx = match.group(1)
match = re.search(r"accel\s*:\s+(\d*)", lines[i+3])
if match:
accel = match.group(1)
match = re.search(r"acc\s*:\s*(\d*)", lines[i+4])
if match:
acc = match.group(1)
print("'accounting': true, 'rx': {}, 'accel': {}, 'acc': {}".format(rx, accel, acc))

Unique list from dynamic range table with possible blanks

I have an Excel table in sheet1 in which column A:
Name of company Company 1 Company 2 Company
3 Company 1 Company 4 Company 1 Company
3
I want to extract a unique list of company names to sheet2 also in column A. I can only do this with help of a helper column if I dont have any blanks between company names but when I do have I get one more company which is a blank.
Also, I've researched but the example was for non-dynamic tables and so it doesn't work because I don't know the length of my column.
I want in Sheet2 Column A:
Name of company Company 1 Company 2 Company 3
Company 4
Looking for the solution that requires less computational power Excel or Excel-VBA. The final order which they appear in sheet2 don't really matter.
Using a slight modification to Recorder-generated code:
Sub Macro1()
Sheets("Sheet1").Range("A:A").Copy Sheets("Sheet2").Range("A1")
Sheets("Sheet2").Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
With Sheets("Sheet2").Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A2:A" & Rows.Count) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A2:A" & Rows.Count)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Sample Sheet1:
Sample Sheet2:
The sort removes the blanks.
EDIT#1:
If the original data in Sheet1 was derived from formulas, then using PasteSpecial will remove unwanted formula copying. There is also a final sweep for empty cells:
Sub Macro1_The_Sequel()
Dim rng As Range
Sheets("Sheet1").Range("A:A").Copy
Sheets("Sheet2").Range("A1").PasteSpecial Paste:=xlPasteValues
Sheets("Sheet2").Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
Set rng = Sheets("Sheet2").Range("A2:A" & Rows.Count)
With Sheets("Sheet2").Sort
.SortFields.Clear
.SortFields.Add Key:=rng, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rng
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Call Kleanup
End Sub
Sub Kleanup()
Dim N As Long, i As Long
With Sheets("Sheet2")
N = .Cells(Rows.Count, "A").End(xlUp).Row
For i = N To 1 Step -1
If .Cells(i, "A").Value = "" Then
.Cells(i, "A").Delete shift:=xlUp
End If
Next i
End With
End Sub
All of these answers use VBA. The easiest way to do this is to use a pivot table.
First, select your data, including the header row, and go to Insert -> PivotTable:
Then you will get a dialog box. You don't need to select any of the options here, just click OK. This will create a new sheet with a blank pivot table. You then need to tell Excel what data you're looking for. In this case, you only want the Name of company in the Rows section. On the right-hand side of Excel you will see a new section named PivotTable Fields. In this section, simply click and drag the header to the Rows section:
This will give a result with just the unique names and an entry with (blank) at the bottom:
If you don't want to use the Pivot Table further, simply copy and paste the result rows you're interested in (in this case, the unique company names) into a new column or sheet to get just those without the pivot table attached. If you want to keep the pivot table, you can right click on Grand Total and remove that, as well as filter the list to remove the (blank) entry.
Either way, you now have your list of unique results without blanks and it didn't require any formulas or VBA, and it took relatively few resources to complete (far fewer than any VBA or formula solution).
Here's another method using Excel's built-in Remove Duplicates feature, and a programmed method to remove the blank lines:
EDIT
I have deleted the code using the above methodology as it takes too long to run. I have replaced it with a method that uses VBA's collection object to compile a unique list of companies.
The first method, on my machine, took about two seconds to run; the method below: about 0.02 seconds.
Sub RemoveDups()
Dim wsSrc As Worksheet, wsDest As Worksheet
Dim rRes As Range
Dim I As Long, S As String
Dim vSrc As Variant, vRes() As Variant, COL As Collection
Set wsSrc = Worksheets("sheet1")
Set wsDest = Worksheets("sheet2")
Set rRes = wsDest.Cells(1, 1)
'Get the source data
With wsSrc
vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
'Collect unique list of companies
Set COL = New Collection
On Error Resume Next
For I = 2 To UBound(vSrc, 1) 'Assume Row 1 is the header
S = CStr(Trim(vSrc(I, 1)))
If Len(S) > 0 Then COL.Add S, S
Next I
On Error GoTo 0
'Populate results array
ReDim vRes(0 To COL.Count, 1 To 1)
'Header
vRes(0, 1) = vSrc(1, 1)
'Companies
For I = 1 To COL.Count
vRes(I, 1) = COL(I)
Next I
'set results range
Set rRes = rRes.Resize(UBound(vRes, 1) + 1)
'Write the results
With rRes
.EntireColumn.Clear
.Value = vRes
.EntireColumn.AutoFit
'Uncomment the below line if you want
'.Sort key1:=.Columns(1), order1:=xlAscending, MatchCase:=False, Header:=xlYes
End With
End Sub
NOTE: You wrote you didn't care about the order, but if you want to Sort the results, that added about 0.03 seconds to the routine.
With two sheets named 1 and 2
Inside sheet named: 1
+----+-----------------+
| | A |
+----+-----------------+
| 1 | Name of company |
| 2 | Company 1 |
| 3 | Company 2 |
| 4 | |
| 5 | Company 3 |
| 6 | Company 1 |
| 7 | |
| 8 | Company 4 |
| 9 | Company 1 |
| 10 | Company 3 |
+----+-----------------+
Result in sheet named: 2
+---+-----------------+
| | A |
+---+-----------------+
| 1 | Name of company |
| 2 | Company 1 |
| 3 | Company 2 |
| 4 | Company 3 |
| 5 | Company 4 |
+---+-----------------+
Use this code in a regular module:
Sub extractUni()
Dim objDic
Dim Cell
Dim Area As Range
Dim i
Dim Value
Set Area = Sheets("1").Range("A2:A10") 'this is where your data is located
Set objDic = CreateObject("Scripting.Dictionary") 'use a Dictonary!
For Each Cell In Area
If Not objDic.Exists(Cell.Value) Then
objDic.Add Cell.Value, Cell.Address
End If
Next
i = 2 '2 because the heading
For Each Value In objDic.Keys
If Not Value = Empty Then
Sheets("2").Cells(i, 1).Value = Value 'Store the data in column D below the heading
i = i + 1
End If
Next
End Sub
The code return the date unsorted, just the way data appears.
if you want a sorted list, just add this code before the las line:
Dim sht As Worksheet
Set sht = Sheets("2")
sht.Activate
With sht.Sort
.SetRange Range("A:A")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
This way the result will be always sorted.
(The subrutine would be like this)
Sub extractUni()
Dim objDic
Dim Cell
Dim Area As Range
Dim i
Dim Value
Set Area = Sheets("1").Range("A2:A10") 'this is where your data is located
Set objDic = CreateObject("Scripting.Dictionary") 'use a Dictonary!
For Each Cell In Area
If Not objDic.Exists(Cell.Value) Then
objDic.Add Cell.Value, Cell.Address
End If
Next
i = 2 '2 because the heading
For Each Value In objDic.Keys
If Not Value = Empty Then
Sheets("2").Cells(i, 1).Value = Value 'Store the data in column D below the heading
i = i + 1
End If
Next
Dim sht As Worksheet
Set sht = Sheets("2")
sht.Activate
With sht.Sort
.SetRange Range("A:A")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
If you have any question about the code, I will glad to explain.

For Next Loop to calculate running total won't work

The majority of my code works other than the 'Calculate Totals' button. I have three listboxes and need my 'Calculate Totals' button to iterate through the selected costs in the 'lstCosts' listbox. However in Option Strict On I receive an error as "List is not a member of Double" and "ListCount is not a member of Double" Can someone help rectify this? I know my code is close to working I just don't know how.
Below is my code which isn't working:
Private Sub btnAddCourse_Click(sender As System.Object, e As System.EventArgs) Handles btnAddCourse.Click
'Declare variables
Dim strCourse As String 'To hold the Course Values
Dim strLocation As String 'To hold the Location values
'Item Indexing
'Identifies the four Course strings
strCourse = lstCourse.Items(0).ToString()
strCourse = lstCourse.Items(1).ToString()
strCourse = lstCourse.Items(2).ToString()
strCourse = lstCourse.Items(3).ToString()
'Identifies the four Location strings
strLocation = lstLocation.Items(0).ToString()
strLocation = lstLocation.Items(1).ToString()
strLocation = lstLocation.Items(2).ToString()
strLocation = lstLocation.Items(3).ToString()
If lstCourse.SelectedIndex = -1 Then
'Error Message for no course selected
MessageBox.Show("Select a course.", "Error", _
MessageBoxButtons.OK, MessageBoxIcon.Error)
ElseIf lstLocation.SelectedIndex = -1 Then
'Error message for no location selected
MessageBox.Show("Select a location.", "Error", _
MessageBoxButtons.OK, MessageBoxIcon.Error)
'Essential Linux and Belfast selected = £705
ElseIf lstCourse.SelectedIndex = 0 And lstLocation.SelectedIndex = 0 Then
lstCosts.Items.Add(705)
'Essential Linux and Coleraine selected = £600
ElseIf lstCourse.SelectedIndex = 0 And lstLocation.SelectedIndex = 1 Then
lstCosts.Items.Add(600)
'Essential Linux and Jordasntown selected = £600
ElseIf lstCourse.SelectedIndex = 0 And lstLocation.SelectedIndex = 2 Then
lstCosts.Items.Add(600)
'Essential Linux and Magee selected = £630
ElseIf lstCourse.SelectedIndex = 0 And lstLocation.SelectedIndex = 3 Then
lstCosts.Items.Add(630)
'Project Management and Belfast selected £520
ElseIf lstCourse.SelectedIndex = 1 And lstLocation.SelectedIndex = 0 Then
lstCosts.Items.Add(520)
'Project Management and Coleraine selected = £450
ElseIf lstCourse.SelectedIndex = 1 And lstLocation.SelectedIndex = 1 Then
lstCosts.Items.Add(450)
'Project Management and Jordanstown selected = £450
ElseIf lstCourse.SelectedIndex = 1 And lstLocation.SelectedIndex = 2 Then
lstCosts.Items.Add(450)
'Project Management and Magee selected = £470
ElseIf lstCourse.SelectedIndex = 1 And lstLocation.SelectedIndex = 3 Then
lstCosts.Items.Add(470)
'Overview of net and Belfast selected = £705
ElseIf lstCourse.SelectedIndex = 2 And lstLocation.SelectedIndex = 0 Then
lstCosts.Items.Add(705)
'Overview of net and Coleraine selected = £575
ElseIf lstCourse.SelectedIndex = 2 And lstLocation.SelectedIndex = 1 Then
lstCosts.Items.Add(575)
'Overview of net and Jordanstown selected = £575
ElseIf lstCourse.SelectedIndex = 2 And lstLocation.SelectedIndex = 2 Then
lstCosts.Items.Add(575)
'Overview of net and Magee selected = £605
ElseIf lstCourse.SelectedIndex = 2 And lstLocation.SelectedIndex = 3 Then
lstCosts.Items.Add(605)
'PHP and Belfast selected = £780
ElseIf lstCourse.SelectedIndex = 3 And lstLocation.SelectedIndex = 0 Then
lstCosts.Items.Add(780)
'PHP and Coleraine selected = £675
ElseIf lstCourse.SelectedIndex = 3 And lstLocation.SelectedIndex = 1 Then
lstCosts.Items.Add(675)
'PHP and Jordanstown selected = £675
ElseIf lstCourse.SelectedIndex = 3 And lstLocation.SelectedIndex = 2 Then
lstCosts.Items.Add(675)
'PHP and Magee selected = £705
ElseIf lstCourse.SelectedIndex = 3 And lstLocation.SelectedIndex = 3 Then
lstCosts.Items.Add(705)
End If
End Sub
Private Sub btnCalculateTotal_Click(sender As Object, e As EventArgs) Handles btnCalculateTotal.Click
Dim lstCosts As Double
Dim lblTotalCost As Double
For lstCosts = 0 To lstCosts.ListCount - 1
lblTotalCost = lblTotalCost + CDbl(lstCosts.List(lstCosts))
Next lstCosts
lblTotalCost = lstCosts
End Sub
Private Sub btnReset_Click(sender As Object, e As EventArgs) Handles btnReset.Click
'Clears the fields
lstCourse.ClearSelected()
lstLocation.ClearSelected()
lstCosts.Items.Clear()
lblTotalCost.Text = String.Empty
End Sub
Private Sub btnExit_Click(sender As Object, e As EventArgs) Handles btnExit.Click
'Closes the Program
Me.Close()
End Sub
when I Looked before there was more code to support my solution.
I think you have 2 issues local vs global naming, and assignment.
Private Sub btnCalculateTotal_Click(sender As Object, e As EventArgs) Handles btnCalculateTotal.Click
'Declare variables
Dim lvIterate As Double '
Dim lvTotalOfCost As Double
'Calculate Total Cost
For lvIterate = 0 To lstCosts.ListCount - 1
lvTotalOfCost = lvTotalOfCost + CDbl(lstCosts.List(lvIterate))
Next
lblTotalCost.Text = lvTotalOfCost
End Sub
Hope it solves you issue.

Problem with Win32_PhysicalMedia SerialNumber property

I wrote the following code to get the physical media serial number but in one of my computers it returns null instead.
Does anybody know what the problem is?
Thanks.
var searcher = new ManagementObjectSearcher("SELECT * FROM Win32_PhysicalMedia");
foreach( ManagementObject mo in searcher.Get() )
{
Console.WriteLine("Serial: {0}", mo["SerialNumber"]);
}
The Serial Number is optional, defined by the manufacturer, and for your device it is either blank or unsupported by the driver.
Virtually all hard drives have a serial number, but most USB-style Flash memory sticks do not (generally a cost issue). I would imagine most unbranded CD/DVD/BD discs would also be non-serialized.
Here is the code I used, the serial number somehow is returned raw with each pair of chars reversed (strange) and using Win32_PhysicalMedia gave different results if I ran the code as a user or an Administrator(more strange) - Windows 7 Ultimate, VS 2008 using VB only:
Function GetHDSerial() As String
Dim strHDSerial As String = String.Empty
Dim index As Integer = 0
Dim Data As String
Dim Data2 As String
Dim ndx As Integer
Dim query As New SelectQuery("Win32_DiskDrive")
Dim search As New ManagementObjectSearcher(query)
Dim info As ManagementObject
Try
For Each info In search.Get()
Data = info("SerialNumber")
Data2 = ""
For ndx = 1 To Data.Length - 1 Step 2
Data2 = Data2 & Chr(Val("&H" & Mid(Data, ndx, 2)))
Next ndx
Data = String.Empty
For ndx = 1 To Data2.Length - 1 Step 2
Data = Data & Mid(Data2, ndx + 1, 1) & Mid(Data2, ndx, 1)
Next
Data2 = Data
If Len(Data) < 8 Then Data2 = "00000000" 'some drives have no s/n
Data2 = Replace(Data2, " ", "") ' some drives pad spaces in the s/n
'forget removeable drives
If InStr(info("MediaType").ToString, "Fixed", CompareMethod.Text) > 0 Then
strHDSerial = strHDSerial & "Drive " & index.ToString & " SN: " & Data2 & vbCrLf
index += 1
End If
Next
Catch ex As Exception
strHDSerial = "Error retrieving SN for Drive "
msgbox(index.ToString)
End Try
Return strHDSerial
End Function