I'm trying to relabel a bunch of Power BI reports and I am doing that with this script.
(Source) =>
let
res = List.Accumulate(
Text.ToList(Source),
[result="", index=0, source=Source],
fnAccumulator
),
IsUpper = (txt) => txt <> "" and txt = Text.Upper(txt) and txt <> Text.Lower(txt),
fnAccumulator =
(state as record, current as text) as record =>
let
prevCharacter =
if state[index]=0 then
""
else
Text.At(state[source], state[index] - 1),
prevCharacter2 =
if state[index]<=1 then
""
else
Text.At(state[source], state[index] - 2),
nextCharacter =
if state[index] = Text.Length(state[source]) - 1 then
""
else
Text.At(state[source], state[index] + 1),
aggregatedResult =
if state[index]=0 or current = "" then
current
else
if IsUpper(current) and
(not IsUpper(prevCharacter) or
(IsUpper(prevCharacter2) and not IsUpper(nextCharacter))) then
state[result] & " " & current
else
state[result] & current,
resultRecord =
if aggregatedResult = null then
null
else
[result = aggregatedResult, index = state[index]+1, source = state[source]]
in
resultRecord
in
res[result]
The problem is after running this on every table and applying the changes all the relationships in the report end up nuked.
Before
After
My thought process is that because my script isn't taking into account SID's and renaming those when they should stay the same this is breaking the relationships. Would appreciate either an alternative way of mass renaming these columns or if there is a way to add an exclusion statement into my script that will ignore any and all SIDs
The below code will split 1 cell into 3 or 4 column based on a pattern of 6chr,5chr,4chr,5+chr. The below also needs to be available on all open workbooks and work from the user selection.
How to fix a bug that after the first splitting of the cell is done and by mistake you run it again will override the data?
Class Module
Option Explicit
'Rename this Class Module cFabric
Private pStyle As String
Private pFabric As String
Private pColour As String
Private pSize As String
Public Property Get Style() As String
Style = pStyle
End Property
Public Property Let Style(Value As String)
pStyle = Value
End Property
Public Property Get Fabric() As String
Fabric = pFabric
End Property
Public Property Let Fabric(Value As String)
pFabric = UCase(Value)
End Property
Public Property Get Colour() As String
Colour = pColour
End Property
Public Property Let Colour(Value As String)
pColour = Value
End Property
Public Property Get Size() As String
Size = pSize
End Property
Public Property Let Size(Value As String)
pSize = Value
End Property
Regular Module
Option Explicit
Sub Fabrics()
Dim wsSrc As Workbook, wsRes As Workbook
Dim vSrc As Variant, vRes As Variant, rRes As Range
Dim RE As Object, MC As Object
Const sPat As String = "^(.{6})\s*(.{5})\s*(.{4})(?:.*1/(\S+))?"
'Group 1 = style
'Group 2 = fabric
'Group 3 = colour
'Group 4 = size
Dim colF As Collection, cF As cFabric
Dim I As Long
Dim S As String
Dim V As Variant
'Set source and results worksheets and ranges
Set wsSrc = ActiveWorkbook
Set wsRes = ActiveWorkbook
Set rRes = wsRes.Application.Selection
'Read source data into array
vSrc = Application.Selection
'Initialize the Collection object
Set colF = New Collection
'Initialize the Regex Object
Set RE = CreateObject("vbscript.regexp")
With RE
.Global = False
.MultiLine = True
.Pattern = sPat
'Test for single cell
If Not IsArray(vSrc) Then
V = vSrc
ReDim vSrc(1 To 1, 1 To 1)
vSrc(1, 1) = V
End If
'iterate through the list
For I = 1 To UBound(vSrc, 1)
S = vSrc(I, 1)
Set cF = New cFabric
If .test(S) = True Then
Set MC = .Execute(S)
With MC(0)
cF.Style = .submatches(0)
cF.Fabric = .submatches(1)
cF.Colour = .submatches(2)
cF.Size = .submatches(3)
End With
Else
cF.Style = S
End If
colF.Add cF
Next I
End With
'create results array
'Exit if no results
If colF.Count = 0 Then Exit Sub
ReDim vRes(1 To colF.Count, 1 To 4)
'Populate the rest
I = 0
For Each V In colF
I = I + 1
With V
vRes(I, 1) = .Style
vRes(I, 2) = .Fabric
vRes(I, 3) = .Colour
vRes(I, 4) = .Size
End With
Next V
'Write the results
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
rRes.Value = vRes
End Sub
Credits for the above goes to #Ron Rosenfeld for the project!
One way to tell if the entry has been previously split is as follows
If the regex.test fails, then
If the results line passes, then the item has been previously split
if not, then it is a blank, or a malformed entry
Note that a lot of this could be avoided if you were not overwriting your original data. I would recommend against overwriting your data both for audit and debugging purposes, but the below should help in case you cannot change that.
You just need to make some small changes in the logic where we checked for the malformed entry originally. As well as reading in the "possible" results array into vSrc so that we have the potentially split data to compare:
Option Explicit
Sub Fabrics()
'assume data is in column A
Dim wsSrc As Worksheet, wsRes As Worksheet
Dim vSrc As Variant, vRes As Variant, rRes As Range
Dim RE As Object, MC As Object
Const sPat As String = "^(.{6})\s*(.{5})\s*(.{4})(?:.*1/(\S+))?"
'Group 1 = style
'Group 2 = fabric
'Group 3 = colour
'Group 4 = size
Dim colF As Collection, cF As cFabric
Dim I As Long
Dim S As String
Dim V As Variant
'Set source and results worksheets and ranges
Set wsSrc = ActiveSheet
Set wsRes = ActiveSheet
Set rRes = Selection
'Read source data into array
vSrc = Selection.Resize(columnsize:=4)
'Initialize the Collection object
Set colF = New Collection
'Initialize the Regex Object
Set RE = CreateObject("vbscript.regexp")
With RE
.Global = False
.MultiLine = True
.Pattern = sPat
'iterate through the list
'Test for single cell
If Not IsArray(vSrc) Then
V = vSrc
ReDim vSrc(1 To 1, 1 To 1)
vSrc(1, 1) = V
End If
For I = 1 To UBound(vSrc, 1)
S = vSrc(I, 1)
Set cF = New cFabric
If .test(S) = True Then
Set MC = .Execute(S)
With MC(0)
cF.Style = .submatches(0)
cF.Fabric = .submatches(1)
cF.Colour = .submatches(2)
cF.Size = .submatches(3)
End With
ElseIf .test(vSrc(I, 1) & vSrc(I, 2) & vSrc(I, 3)) = False Then
cF.Style = S
Else
cF.Style = vSrc(I, 1)
cF.Fabric = vSrc(I, 2)
cF.Colour = vSrc(I, 3)
cF.Size = vSrc(I, 4)
End If
colF.Add cF
Next I
End With
'create results array
'Exit if not results
If colF.Count = 0 Then Exit Sub
ReDim vRes(1 To colF.Count, 1 To 4)
'Populate
I = 0
For Each V In colF
I = I + 1
With V
vRes(I, 1) = .Style
vRes(I, 2) = .Fabric
vRes(I, 3) = .Colour
vRes(I, 4) = .Size
End With
Next V
'Write the results
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
.Clear
.NumberFormat = "#"
.Value = vRes
.EntireColumn.AutoFit
End With
End Sub
Disregarding the previous regex/class method,
Option Explicit
Sub Fabrics_part_Deux()
Dim a As Long, b As Long
With Worksheets("Sheet1")
If .AutoFilterMode Then .AutoFilterMode = False
With .Range(.Cells(1, "A"), .Cells(.Rows.Count, "B").End(xlUp).Offset(0, 3))
With .Columns("B")
.Offset(1, 0).Replace what:=Chr(32), replacement:=vbNullString, lookat:=xlPart
End With
.AutoFilter field:=2, Criteria1:="<>"
.AutoFilter field:=3, Criteria1:=""
With .Resize(.Rows.Count - 1, 1).Offset(1, 1)
If CBool(Application.Subtotal(103, .Cells)) Then
With .SpecialCells(xlCellTypeVisible)
For a = 1 To .Areas.Count
With .Areas(a).Cells
.TextToColumns Destination:=.Cells(1), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(6, 1), Array(11, 1), Array(15, 2))
For b = 1 To .Rows.Count
.Cells(b, 2) = UCase$(.Cells(b, 2).Value2)
If CBool(InStr(1, .Cells(b, 4).Value2, Chr(47), vbBinaryCompare)) Then
.Cells(b, 4) = Trim(Split(.Cells(b, 4), Chr(47))(1))
End If
Next b
End With
Next a
End With
End If
End With
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
End Sub
In your code to output to the spreadsheet, you need to check for empty strings
I = 0
For Each V In colF
I = I + 1
With V
vRes(I, 1) = .Style
If len(.Fabric) > 0 then
vRes(I, 2) = .Fabric
vRes(I, 3) = .Colour
vRes(I, 4) = .Size
End If
End With
Next V
I'm writing a VBScript that searches the Active Directory for a computer object. If the object does not exist or exists and is in the correct OU, then it should run a separate script that creates/joins the computer to the AD.
ObjExist_CorrectOU_7 = Null
ObjExist_CorrectOU_10 = Null
If compare = True Then
Win7_OU = "OU=DisallowRDP,OU=64Bit,OU=Win8"
Win10_OU = "OU=DisallowRDP,OU=64Bit,OU=Win10"
For x = 16 To 46
If Asc(Mid(objRS.Fields("distinguishedName"), x, 1)) = Asc(Mid(Win7_OU, (x - 15), 1)) Then
ObjExist_CorrectOU_7 = True
Else
ObjExist_CorrectOU_7 = False
End If
Next
For y = 16 To 46
If Asc(Mid(objRS.Fields("distinguishedName"), y, 1)) = Asc(Mid(Win10_OU, (y - 15), 1)) Then
ObjExist_CorrectOU_10 = True
Else
ObjExist_CorrectOU_10 = False
End If
Next
End If
If ObjExist_CorrectOU_7 = True Then
WScript.Echo "TRUE"
End If
Dim objShell
Set objShell = WScript.CreateObject("WScript.Shell")
filename = "C:\programdata\dell\kace\k2000_deployment_info.conf"
Win7_Deployment = "deployment_name=Windows 7 x64 with SP1, join AD"
Win10_Deployment = "deployment_name=Development Windows 10 (x64), join AD"
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile(filename)
Do While Not f.AtEndOfStream
If ((f.ReadLine = Win7_Deployment) Or ((f.ReadLine = Win7_Deployment) And (ObjExist_CorrectOU_7 = True))) Then
WScript.Echo "IT WORKED!"
'objShell.Run "JoinAD_Win7.vbs"
Exit Do
End If
On Error Resume Next
Loop
f.Close
Set g = fso.OpenTextFile(filename)
Do While Not f.AtEndOfStream
If ((g.ReadLine = Win10_Deployment) Or ((g.ReadLine = Win10_Deployment) And (ObjExist_CorrectOU_10 = True))) Then
'objShell.Run "JoinAD_Win10.vbs"
WScript.Echo "IT WORKED AGAIN!"
Exit Do
End If
On Error Resume Next
Loop
g.Close
Set objShell = Nothing
The problem I'm running into is that the two If..Then statements execute every time, even though I know the conditions are absolutely NOT being met.
Does it have to do with my use of Or and And?
Your question does not satisfy Minimal, Complete, and Verifiable example criteria. However, at first sight: read On Error Statement and ReadLine Method and Working with Files documentation.
Do While Not f.AtEndOfStream
''' ↓ this `ReadLine` reads every uneven line i.e. the 1st, 3rd, 5th, …
If ((f.ReadLine = Win7_Deployment) Or ((f.ReadLine = Win7_Deployment) And (ObjExist_CorrectOU_7 = True))) Then
''' this one reads every even line ↑ i.e. the 2nd, 4th, 6th, …
WScript.Echo "IT WORKED!"
'objShell.Run "JoinAD_Win7.vbs"
Exit Do
End If
On Error Resume Next ' this causes that script continues on line next to IF … THEN
' in case of uneven records in file.
' i.e. runtimme error "Input past end of file"
Loop
Use something like
Do While Not f.AtEndOfStream
sReadLine = f.ReadLine
If ((sReadLine = Win7_Deployment) Or ((sReadLine = Win7_Deployment) And (ObjExist_CorrectOU_7 = True))) Then
WScript.Echo "IT WORKED!"
'objShell.Run "JoinAD_Win7.vbs"
Exit Do
End If
''' get rid of `On Error Resume Next` statement at all
Loop
And what about Do While Not f.AtEndOfStream followed up by g.ReadLine? Use either f or g (the same TextStream object in both)…
How do I do the following using DAO on a recordset
SELECT TOP 1 * FROM foo WHERE id = 10 ORDER BY timestamp DESC
Using SetCurrentIndex you can only use one index it seems otherwise using id and timestamp and selecting the first one would work.
I am by no means sure of what you want.
Dim rs As DAO.Recordset
Dim db As Database
Set db = CurrentDB
sSQL = "SELECT TOP 1 * FROM foo WHERE id = 10 ORDER BY timestamp DESC"
Set rs = db.OpenRecordset(sSQL)
Find does not work with all recordsets. This will work:
Set rs = CurrentDb.OpenRecordset("select * from table1")
rs.FindFirst "akey=1 and atext='b'"
If Not rs.EOF Then Debug.Print rs!AKey
This will not:
Set rs = CurrentDb.OpenRecordset("table1")
rs.FindFirst "akey=1 and atext='b'"
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