This is what I have:
Dim pathBefore
pathBefore = "product/subproduct/item/item"
This is what I need to get from pathBefore:
Dim pathAfter
pathAfter = "product/subproduct/item"
What I can do to achieve this?
I have tried with RegEx but it is not acceptable solution.
#Gurman:
>> s = "product/subproduct/item/item"
>> a = Split(s, "/")
>> ReDim Preserve a(UBound(a) - 1)
>> WScript.Echo Join(a, "/")
>> WScript.Echo goFS.GetParentFolderName(s)
>> WScript.Echo Left(s, InstrRev(s, "/") - 1)
>>
product/subproduct/item
product/subproduct/item
product/subproduct/item
Try this code:
Dim pathBefore, pathAfter, temp, i
pathBefore = "product/subproduct/item/item"
temp = Split(pathBefore,"/")
For i=0 To UBound(temp)-1
pathAfter = pathAfter & temp(i) & "/"
Next
pathAfter = Left(pathAfter,Len(pathAfter)-1)
MsgBox pathAfter
Output:
Find the last / then read upto that point - 1
pathAfter = left$(pathBefore, instrrev(pathBefore, "/") - 1)
Related
I am not sure why but this cet = Split(strCSV, " - ") causes Run time error 5: Invalid procedure call or argument.
strCSV = Trim(cWk.Range("P" & i)): dt = CDate(CLng(cWk.Range("H" & i)))
where str = "Cap Style:Snapback - CD / Number:07 / Color:First Avenger(+S$1.50) / Box:none - Only Purchase 3 caps and above - Free Box "
Following code works perfectly on windows but it throws error on the above mentioned line
Option Explicit
Option Compare Text
Sub Get_Data()
Application.ScreenUpdating = False
Dim fName, wkB2 As Workbook, cWk As Worksheet, xWk As Worksheet, frowC As Long, i As Long, j As Long, ch As String, num As String
Dim strCSV As String, dt As Date, shtName As String, cet, temp As String, rng As Range, cel As Range, cl As String, rw As Long, toF As String
On Error GoTo Err
fName = Application.GetOpenFilename
If fName <> False Then
Set wkB2 = Workbooks.Open(fName): Set cWk = wkB2.Worksheets(1): frowC = cWk.Range("P" & Rows.Count).End(xlUp).Row
'Cap Style:Baseball - CC / Number:04 / Color:Grey(+S$2) / Box:none - Only Purchase 3 caps and above - Free Box
'Cap Style:SnapBack - CC / Number:04 / Color:Grey(+S$1.50) / Box:none - Only Purchase 3 caps and above - Free Box
For i = 2 To frowC
strCSV = Trim(cWk.Range("P" & i)): dt = CDate(CLng(cWk.Range("H" & i)))
If strCSV <> "" And IsDate(dt) Then
'ERROR cet = Split(strCSV, " - "): temp = cet(LBound(cet)): cet = Split(temp, ":"): shtName = Trim(cet(UBound(cet)))
For Each xWk In ThisWorkbook.Worksheets
If shtName = Trim(xWk.Name) Then
Set rng = xWk.Range("E3:BD3")
For Each cel In rng
If cel.Value = dt Then
cet = Split(cel.Address, "$"): cl = cet(UBound(cet) - 1): Exit For
End If
Next cel
cet = Split(strCSV, "Number:"): temp = cet(UBound(cet)): cet = Split(temp, "/"): num = Trim(cet(LBound(cet)))
cet = Split(strCSV, " / "): temp = cet(LBound(cet)): cet = Split(temp, " - "): ch = Trim(cet(UBound(cet))): ch = ch & "-" & num
Debug.Print "Ch is " & ch
Set rng = xWk.Range("A1:A" & xWk.Range("A" & Rows.Count).End(xlUp).Row)
For Each cel In rng
If cel.Value = ch Then
rw = cel.Row: Exit For
End If
Next cel
cet = Split(strCSV, "Color:"): temp = cet(UBound(cet)): cet = Split(temp, "("): toF = Trim(cet(LBound(cet)))
For j = rw To rw - 10 Step -1
If Trim(xWk.Range("B" & j)) = toF Then
rw = j: Exit For
End If
Next j
Debug.Print "Address is: " & cl & rw & " for row " & i
xWk.Range(cl & rw) = cWk.Range("O" & i)
Exit For
End If
Next xWk
End If
Next i
wkB2.Close False
Else
Exit Sub
End If
Application.ScreenUpdating = True
MsgBox "Done"
Exit Sub
Err:
MsgBox Err.Description
End Sub
Update: SplitString now handle multi-character delimiters.
We conclude that older versions of Mac Office use the equivalent of VB5. Since the Split function was introduced in VB6. An Invalid procedure call or argument is being thrown because the Split function is not available in VB5.
The workaround would be to create a custom function that works like Spli.
Split Replacement Function
Function SplitString(Text As String, Delimiter As String)
Dim arr() As String, s As String
Dim i As Long, iEnd As Long, iStart As Long, length As Long
length = Len(Delimiter)
ReDim Preserve arr(0)
iStart = 1
Do
iEnd = InStr(Mid(Text, iStart), Delimiter) - 1
If iEnd = -1 Then
ReDim Preserve arr(i)
arr(i) = Mid(Text, iStart)
Exit Do
Else
ReDim Preserve arr(i)
arr(i) = Mid(Text, iStart, iEnd)
iStart = iStart + iEnd + length
i = i + 1
End If
Loop Until iStart = 0
SplitString = arr
End Function
Here are the tests that I ran
Sub BatchTest()
Dim strCSV As String, Temp As String, Delimiter As String
Dim a
strCSV = "Cap Style Snapback - CD / Number 07 / Color First Avenger(+S$1.50) / Box none - Only Purchase 3 caps and above - Free Box"
a = SplitString(strCSV, "/")
TestSplit strCSV, " / "
TestSplit strCSV, " /"
TestSplit strCSV, "/"
TestSplit strCSV, " Color First"
End Sub
Sub TestSplit(Text As String, Delimiter As String)
Dim arr As Variant, sReplcement As String
arr = SplitString(Text, Delimiter)
sReplcement = Replace(Text, Delimiter, "|")
Debug.Print sReplcement
Debug.Print Join(arr, "|")
Debug.Print sReplcement = Join(arr, "|")
End Sub
The Results of the tests
Sub TestRegEx()
MsgBox RegexExtract("sdi 99090 dfddf sdi 5666", "(sdi \d+)", ", ") = "sdi 99090, sdi 5666"
End Sub
Function RegexExtract(ByVal text As String, _
ByVal extract_what As String, _
Optional seperator As String = "") As String
Dim i As Long, j As Long
Dim result As String
Dim allMatches As Object
Dim RE As Object
Set RE = CreateObject("vbscript.regexp")
RE.Pattern = extract_what
RE.Global = True
Set allMatches = RE.Execute(text)
For i = 0 To allMatches.count - 1
For j = 0 To allMatches.Item(i).submatches.count - 1
result = result & seperator & allMatches.Item(i).submatches.Item(j)
Next
Next
If Len(result) <> 0 Then
result = Right(result, Len(result) - Len(seperator))
End If
RegexExtract = result
End Function
Ok, like many other people, I am a noob on VB Scripting. What I am trying to do is create a VB Script that will manipulate a file name from Fulton A1032-CCC Adamsville to just A1032-CCC. I have browsed many site trying to find the answer but only came up with on that halfway worked.
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colFiles = objWMIService.ExecQuery _
("ASSOCIATORS OF {Win32_Directory.Name='H:\Darrell 2014 folder\Distview Wiki Revamp\To'} Where " _
& "ResultClass = CIM_DataFile")
For Each objFile In colFiles
strPath = objFile.Drive & objFile.Path
strExtension = objFile.Extension
strFileName = objFile.FileName
If Left(strFileName, 7) = "Fulton " Then
intLength = Len(strFileName)
strFileName = Right(strFileName, intLength - 7)
End If
If Right(strFileName, 10) = " Adamsville" Then
intLength = Len(strFileName)
strFileName = Left(strFileName, intLength - 10)
End If
strNewName = strPath & strFileName & "." & strExtension
errResult = objFile.Rename(strNewName)
Next
Please Help
Why not just use the replace function instead? For example:
Dim fileName As String
fileName = "Fulton A1032-CCC Adamsville"
fileName = Replace(fileName, "Fulton ", "")
fileName = Replace(fileName, " Adamsville", "")
MsgBox fileName
The output is A1032-CCC. This also works if either or both of the search strings don't exist.
Learn to count:
>> WScript.Echo Len(" Adamsville")
>>
11
>>
or write a function:
>> Function endsWith(b, t)
>> endsWith = Right(b, len(t)) = t
>> End Function
>> WScript.Echo CStr(endsWith("Fulton A1032-CCC Adamsville", " Adamsville"))
>>
True
Update wrt downvotes:
As the downvotes indicate that there are at least two people who can't count either:
Option Explicit
Function qq(s) : qq = """" & s & """" : End Function
Dim strFileName : strFileName = "Fulton A1032-CCC Adamsville"
Dim intLength
WScript.Echo 0, qq(strFileName)
' assume the structure of the input data is:
' <todelete+blank><tokeep><blank+todelete>
WScript.Echo 1, qq(Split(strFileName)(1))
' the ot's code 'works' if you count correctly
If Left(strFileName, 7) = "Fulton " Then
intLength = Len(strFileName)
strFileName = Right(strFileName, intLength - 7)
End If
If Right(strFileName, 11) = " Adamsville" Then
intLength = Len(strFileName)
strFileName = Left(strFileName, intLength - 11)
End If
WScript.Echo 2, qq(strFileName)
output:
cscript 25689666.vbs
0 "Fulton A1032-CCC Adamsville"
1 "A1032-CCC"
2 "A1032-CCC"
The script below works in finding duplicates.
But most of the files i'm reading follow this format:
ServerName(1) = "Example1"
ServerName(2) = "Example1"
ServerName(3) = "Example3"
ServerName(4) = "Example4"
ServerName(5) = "Example5"
The 'cut' variable in the code below is supposed to cut the string at the "=" delimiter and return the value that comes after the "=" delimeter.
It should write to the duplicate file "Example1" but instead writes nothing. How would I make it so that the script below reads a file and only finds the duplicate in values after the "=" delimeter.
Const ForReading = 1
Const ForWriting = 2
Set objFSO = CreateObject("Scripting.FileSystemObject")
FileName = "Test.txt"
PathToSave = "C:"
Path = (PathToSave & FileName)
Set objFile = objFSO.OpenTextFile(Path, ForReading)
Set objOutputFile = objFSO.OpenTextFile(PathToSave & "Noduplicates.txt", 2, True)
Set objOutputFile2 = objFSO.OpenTextFile(PathToSave & "Duplicates.txt", 2, True)
objOutputFile.WriteLine ("This document contains the " & path & " file without duplicates" & vbcrlf)
objOutputFile2.WriteLine ("This document contains the duplicates found. Each line listed below had a duplicate in " & Path & vbcrlf)
Dim DuplicateCount
DuplicateCount = 0
Set Dict = CreateObject("Scripting.Dictionary")
Do until objFile.atEndOfStream
strCurrentLine = LCase(Trim(objFile.ReadLine))
Cut = Split(strCurrentline,"=")
If not Dict.Exists(LCase(Trim(cut(strCurrentLine)))) then
objOutputFile.WriteLine strCurrentLine
Dict.Add strCurrentLine,strCurrentLine
Else Dict.Exists(LCase(Trim(cut(strCurrentLine))))
objOutputFile2.WriteLine strCurrentLine
DuplicateCount = DuplicateCount + 1
End if
Loop
If DuplicateCount > 0 then
wscript.echo ("Number of Duplicates Found: " & DuplicateCount)
Else
wscript.echo "No Duplicates found"
End if
Cut is your array, so Cut(1) is the portion after the =. So that's what you should test for in your dictionary.
If InStr(strCurrentline, "=") > 0 Then
Cut = Split(strCurrentline,"=")
If Not Dict.Exists(Cut(1)) then
objOutputFile.WriteLine strCurrentLine
Dict.Add Cut(1), Cut(1)
Else
objOutputFile2.WriteLine strCurrentLine
DuplicateCount = DuplicateCount + 1
End if
End If
I makes no sense at all to ask Split to return an array with one element by setting the 3rd parameter to 1, as in
Cut = Split(strCurrentline,"=",1)
Evidence:
>> WScript.Echo Join(Split("a=b", "=", 1), "*")
>>
a=b
>> WScript.Echo Join(Split("a=b", "="), "*")
>>
a*b
BTW: ServerName(5) = "Example5" should be splitted on " = "; further thought about the quotes may be advisable.
Update wrt comments (and downvotes):
The semantics of the count parameter according to the docs:
count
Optional. Number of substrings to be returned; -1 indicates that all substrings are returned. If omitted, all substrings are returned.
Asking for one element (not an UBound!) results in one element containing the input.
Evidence wrt the type mismatch error:
>> cut = Split("a=b", "=", 1)
>> WScript.Echo cut
>>
Error Number: 13
Error Description: Type mismatch
>>
So please think twice.
I'm trying to create a vbscript that moves files from one directory to another, that increments the filename if the file allready exists. I.e. if file.ext exists, new filename is file_01.ext. If file_01.ext exists, new filename is file_02.ext, and so on. I can't get it to work. Any help would be very much appreciated.
Const cVBS = "Vaskedama.vbs" '= script name
Const cLOG = "Vaskedama.log" '= log filename
Const cFOL = "C:\fra\" '= source folder
Const cMOV = "C:\til\" '= dest. folder
Const cDAZ = -1 '= # days
Dim strMSG
strMSG = " files moved from " & cFOL & " to " & cMOV
MsgBox Move_Files(cFOL) & strMSG,vbInformation,cVBS
Function Move_Files(folder)
Move_Files = 0
Dim strDAT
Dim intDAZ
Dim arrFIL()
ReDim arrFIL(0)
Dim intFIL
intFIL = 0
Dim strFIL
Dim intLEN
intLEN = 0
Dim strLOG
strLOG = "echo " & cVBS & " -- " & Now & vbCrLf
Dim dtmNOW
dtmNOW = Now
Dim objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim objGFO
Dim objGFI
If Not objFSO.FolderExists(cFOL) _
Or Not objFSO.FolderExists(cMOV) Then
MsgBox "A folder does not exist!",vbExclamation,cVBS
Exit Function
End If
Set objGFO = objFSO.GetFolder(folder)
Set objGFI = objGFO.Files
For Each strFIL In objGFI
strDAT = strFIL.DateCreated
intDAZ = DateDiff("d",strDAT,dtmNOW)
If intDAZ > cDAZ Then
intFIL = intFIL + 1
ReDim Preserve arrFIL(intFIL)
arrFIL(intFIL) = strFIL.Name
If intLEN < Len(strFIL.Name) Then
intLEN = Len(strFIL.Name)
End If
End If
Next
For intFIL = 1 To UBound(arrFIL)
strFIL = arrFIL(intFIL)
Do While (objFSO.FileExists(cMOV & strFIL))
strFil = CreateNewName(strFIL, intFIL)
Loop
objFSO.MoveFile folder & strFIL, cMOV & strFIL
strLOG = strLOG & "move " & folder & strFIL _
& Space(intLEN-Len(strFIL)+1) _
& cMOV & strFIL & vbCrLf
Next
Set objGFI = Nothing
Set objGFO = Nothing
strLOG = strLOG & "echo " & UBound(arrFIL) & " files moved"
objFSO.CreateTextFile(cLOG,True).Write(strLOG)
Set objFSO = Nothing
Move_Files = UBound(arrFIL)
End Function
Function CreateNewName(strValue, intValue)
CreateNewName = strValue & intValue
End Function
As I can't understand your script at all, I'll concentrate on the the task "build a new file name by incrementing a counter". Obviously you have to check for each file whether there is a file with the same name or this name + suffix in the destination folder. The answer to this question for file a is completely independent of all files in the source folder - so I doubt your array makes any sense.
In code:
Const cnMax = 3
Dim goFS : Set goFS = CreateObject("Scripting.FileSystemObject")
Dim oSrcDir : Set oSrcDir = goFS.GetFolder("..\testdata\FancyRename\from")
Dim sDstDir : sDstDir = "..\testdata\FancyRename\to"
Dim oFile, nInc, sNFSpec
For Each oFile In oSrcDir.Files
WScript.Echo "looking at", oFile.Name
nInc = 0
sNFSpec = getNewFSpec(oFile.Name, sDstDir, nInc)
Do While goFS.FileExists(sNFSpec) And nInc <= cnMax
sNFSpec = getNewFSpec(oFile.Name, sDstDir, nInc)
Loop
If nInc > cnMax Then
WScript.Echo "won't copy to", sNFSpec
Else
WScript.Echo "will copy to ", sNFSpec
oFile.Copy sNFSpec
End If
Next
Function getNewFSpec(ByVal sFName, sDstDir, ByRef nInc)
If 0 < nInc Then
Dim sSfx
sSfx = goFS.GetExtensionName(sFName)
If "" <> sSfx Then sSfx = "." & sSfx
sSfx = "_" & Right("00" & nInc, 2) & sSfx
sFName = goFS.GetBaseName(sFName) & sSfx
End If
nInc = nInc + 1
getNewFSpec = goFS.BuildPath(sDstDir, sFName)
End Function
some sample output:
looking at B.txt
will copy to ..\testdata\FancyRename\to\B.txt
looking at C.txt
will copy to ..\testdata\FancyRename\to\C.txt
looking at A.txt
will copy to ..\testdata\FancyRename\to\A.txt
looking at B.txt
will copy to ..\testdata\FancyRename\to\B_01.txt
looking at B.txt
won't copy to ..\testdata\FancyRename\to\B_03.txt
I am using dictonary in VBscript. I have some problems that I don't understand some of the behaviour:
Dim CmdData
Set CmdData = CreateObject("System.Dictonary")
CmdData.Add "11", "tttzz"
CmdData.Add "sssid", "KRN"
WScript.Echo(" ZZZZZZZZ= " & CmdData.Count) 'It prints zero and not 2
Dim s
s = CmdData.Item("11")
alert(s)
WScript.Echo(s) 'It prints empry box and not tttzz
Dim a, j
a = CmdData.Keys
For j = 0 To CmdData.Count -1
WScript.Echo(" ZZZZZZZZ= " & CmdData.Count)
WScript.Echo(a(j)) ' doesn not print
Next
If (CmdData.Exists("-ad")) Then
'WScript.Echo (" RR ") ' It prints it although not in the dictonary
End If
Thanks
VBScript's Dictionary is "Scripting.Dictionary":
>> set syd = CreateObject("System.Dictionary")
>> syd.add "a",1
>>
Error Number: 429
Error Description: ActiveX component can't create object
>> set scd = CreateObject("Scripting.Dictionary")
>> scd.add "a",1
>> WScript.Echo scd.Count, scd("a")
>>
1 1