Loop through folder using array to find lastest version (count) with VBA? - arrays

I have attached a code, however, this will only find the files that is present in the folder.
What I want to have is an incremental counter for the files. Thing is that sometimes the version will start something else than 0 or 1, e.g. 3.
Amesto non AN suppliers TEST W20-3 AN then I want the next string to be 4.
I am currently using this, but it will only work if 1 is the first, etc.
I am really stuck.
' Version check
Do While Len(Dir(strPath2 & "Amesto non AN suppliers TEST W" & week & "-" & version & "*.cif")) <> 0
version = version + 1
strPath = getDirectoryPath & "Amesto non AN suppliers TEST W" & week & "-" & version & " " & UserName & ".cif"
Loop
Sub loadversion()
Dim MyFile As String
Dim Counter As Long
'Create a dynamic array variable, and then declare its initial size
Dim DirectoryListArray() As String
ReDim DirectoryListArray(1000)
'Loop through all the files in the directory by using Dir$ function
MyFile = Dir$("C:\Users\niclas.madsen\Desktop\AP\WAVE3\CIF\*.*")
Do While MyFile <> ""
DirectoryListArray(Counter) = MyFile
MyFile = Dir$
Counter = Counter + 1
Loop
' do something here?!
If MyFile = vbNullString Then
Else
End If
'Reset the size of the array without losing its values by using Redim Preserve
ReDim Preserve DirectoryListArray(Counter - 1)
For Counter = 0 To UBound(DirectoryListArray)
'Debug.Print writes the results to the Immediate window (press Ctrl + G to view it)'
Debug.Print DirectoryListArray(Counter)
Next Counter
End Sub

To get the highest version on a filename in your directory, insert the following functions:
Function CheckHighestVersion(path As String, cutLettersAtWordBeginning As Integer) As Integer
Dim file As Variant
Dim toBeCut As String
Dim verLength As Integer
Dim highestVersion As Integer
highestVersion = 0
file = Dir(path)
While (file <> "")
toBeCut = file
toBeCut = Mid(toBeCut, cutLettersAtWordBeginning + 1)
verLength = FindVerLength(toBeCut)
If verLength = -1 Then
CheckHighestVersion = 0
Exit Function
End If
toBeCut = Left(toBeCut, verLength)
If Val(toBeCut) > highestVersion Then
highestVersion = Val(toBeCut)
End If
file = Dir
Wend
CheckHighestVersion = highestVersion
End Function
Function FindVerLength(fileName As String) As Integer
Dim i As Integer
For i = 1 To Len(fileName)
If Not IsNumeric(Mid(fileName, i, 1)) Then
If i = 1 Then
MsgBox "Couldn't obtain the highest version of the files: " & _
"The first letter of the version is not numeric. The letter is " & Mid(fileName, i, 1) & _
". Please use correct amount of letters to be cut at the beginning of the file name."
FindVerLength = -1
Exit Function
End If
FindVerLength = i - 1
Exit Function
End If
Next i
FindVerLength = i
End Function
Call CheckHighestVersion in your Sub. the path is only the directory (e.g. C:\Test\ ), the second parameter is the number of letters you don't need at the beginning of the word. If I counted correctly, that value should be 30+(length of week, week 25 would be 2, week 7 would be 1) in your case. The function returns the highest version contained in that folder.

Related

How can I return a dynamic array from within a function in VBS for later use outside the function?

I've searched through a few websites and have not had any success in finding a solution that fits my needs. I am using a function in VBScript to create two arrays, one based on a specified date range, and the other is a dynamic array based on the filenames at the location of interest. I then compare the values in the two arrays and remove the duplicates from the main array, and check to see which values are weekdays.
So far all of that works. The difficulty I am having is being able to pass the "RangeArr()" array outside of the function. See my working code below:
FindMissingReports(TestPath)
Function FindMissingReports(Path)
Dim FileName, File
Dim RangeArr()
intSize = 0
For i = 0 to 7
ReDim Preserve RangeArr(intSize)
RangeArr(intSize) = Year(Date - i) & "-" & Month(Date - i) & "-" & Day(Date - i)
intSize = intSize +1
Next
'
Dim FileArr()
intSize = 0
'
Set oFSO = CreateObject("Scripting.FileSystemObject")
'Create the object used to display popup boxes
Set objShell = WScript.CreateObject("WScript.Shell")
'Loop through all of the files in the "Path" directory.
For Each File in oFSO.getfolder(Path).Files
'If the file name contains "Defect Report"
If instr(File.Name, "Defect Report") <> 0 Then
Set objFile = oFSO.GetFile(File)
'Define the filename as a variable
FileName = File.Name
'Get the report date from the first 10 characters of the filename.
FileDate = Left(FileName, 10)
ReDim Preserve FileArr(intSize)
FileArr(intSize) = FileDate
intSize = intSize +1
End If
Next
'
For i = 0 to UBound(FileArr)
For j = 0 to UBound(RangeArr)
If UBound(RangeArr) > UBound(FileArr) and UBound(FileArr) <> -1 Then
On Error Resume Next
If FileArr(i) = RangeArr(j) Then
removalIndexFile = i
For x = removalIndexFile to UBound(FileArr) -1
FileArr(x) = FileArr(x+1)
Next
ReDim Preserve FileArr(UBound(FileArr)-1)
removalIndexRange = j
For x = removalIndexRange to UBound(RangeArr) -1
RangeArr(x) = RangeArr(x+1)
Next
ReDim Preserve RangeArr(UBound(RangeArr)-1)
End If
End If
Next
Next
'
For i = 0 to UBound(RangeArr)
If IsWeekday(RangeArr(i)) Then
MsgBox(RangeArr(i) & ". It worked! This is the only weekday report missing from the list.")
End If
Next
'
End Function
Function IsWeekday(theDate)
IsWeekday = Weekday(theDate,vbMonday) <= 5
End Function
The VBScript way to return something from a function is to assign that something to the function's name. Demo:
Option Explicit
' To return x from a function, assign x to the function's name
Function f(p)
Select Case p
Case "Array()"
f = Array("array via Array()")
Case "FuncLikeSplit()"
f = Split("func-returns-(dyn)-array")
Case "DimReDimAssign"
Dim tmp
ReDim tmp(0)
tmp(0) = "Dim-ReDim-Assign"
f = tmp
Case Else
WScript.Echo "Error!"
End Select
End Function
Dim a, p
' prove for each a: it's a dynamic array
For Each p In Split("Array() FuncLikeSplit() DimReDimAssign")
a = f(p)
WScript.Echo p, TypeName(a), UBound(a), a(0)
ReDim Preserve a(Ubound(a) + 1)
a(UBound(a)) = "grownup"
WScript.Echo UBound(a), a(UBound(a))
WScript.Echo "----------------"
Next
output:
cscript 47042147.vbs
Array() Variant() 0 array via Array()
1 grownup
----------------
FuncLikeSplit() Variant() 0 func-returns-(dyn)-array
1 grownup
----------------
DimReDimAssign Variant() 0 Dim-ReDim-Assign
1 grownup
----------------
So:
FindMissingReports = RangeArr
at the end of the function, and:
Dim a : a = FindMissingReports(TestPath)
at the top level.

Store filehandles in array

I try to open all *.xlsx files in a specified folder and store the filehandles in an array.
My code looks like this
Dim Files() As Workbook
ReDim Files(Count)
File = Dir(Path & "\*.xlsx")
Count = 0
Do While File <> ""
Set Files(Count) = Workbooks.Open(Path & File, , True)
Count = Count + 1
File = Dir()
Loop
The code seems to work, however, when I run it a second time (hitting the run button again), I get an error number 13.
Debugging the code I tracked the problem to the line
Set Files(Count) = Workbooks.Open(Path & File, , True)
As I am unexperienced with vba I guess I didn't do this the right way...
What would be a preferable way to store filehandles to all files in a specific folder in an array?
you're missing a path separator
Set Files(Count) = Workbooks.Open(Path & "\" & File, , True)
The code should be:
Dim Files() As Workbook
Dim Count As Integer
ReDim Files(Count)
File = Dir(Path & "\*.xlsx")
Count = 0
Do While File <> ""
ReDim Preserve Files(Count)
Set Files(Count) = Workbooks.Open(Path & File, , True)
Count = Count + 1
File = Dir()
Loop
You need to redim your array. Preserve keeps the existing data.

Regex expression and match function in text file

I have problem with my matching function actually I have to count number of lines with specific string and return line number ,so I have one dimensional array of string that contain the unique strings of text file {33,7,77,3 23,6} and text file with the same strings in array I have read lines of text file to array , but with duplicate of these strings ,when I use regex.match it works not bad expect when I check if line 2 contain 3 the function return True it's consider 3 in 23 as 3 , and the above explanation is just example of what I need any help please
Module Module1
Sub Main()
Dim txt As String = File.ReadAllText("e:\ii.txt")
' Use regular expressions to replace characters
' that are not letters or numbers with spaces.
Dim reg_exp As New Regex("[^a-zA-Z0-9]")
txt = reg_exp.Replace(txt, " ")
' Split the text into words.
'Dim words() As String = txt.Split( _
' New Char() {" "c}, _
' StringSplitOptions.RemoveEmptyEntries)
Dim words = txt.Split(New String() {" ", Environment.NewLine}, StringSplitOptions.RemoveEmptyEntries)
' Use LINQ to get the unique words.
Dim word_query = _
(From word As String In words _
Order By word _
Select word).Distinct()
Dim stra() As String = word_query.ToArray()
For i = 0 To stra.Length - 1
Console.WriteLine(" " & stra(i))
Next
Dim lines() As String = IO.File.ReadAllLines("e:\ii.txt")
For i = 0 To lines.Length - 1
Console.WriteLine(lines(1))
Dim linecount = 0
Dim regex As New Regex(stra(i), RegexOptions.ExplicitCapture)
Dim match As Match = regex.Match(lines(1))
If match.Success Then
linecount += 1
Console.WriteLine("linecount= " & linecount)
Else
Console.WriteLine("false")
End If
Next
End Sub
End Module
You many not have to split the text into words. Is your word list very long? From what I understand you want the following:
1.Read a text file and return the line number for a given word or phrase.
Is the word or phrase complex? If not, why not use a the Contains extension method?
For example:
Dim myString = "Hello World"
If myString.Contains("World") Then
'Add line number to line count.
End if
If you are using this as an opportunity to learn regular expressions, I highly recommend "Mastering Regular Expressions" by Jeffrey Friedl. When I first begun I invested in a program RegexBuddy, which is worth the money. But now there are so many online regex testers now, that could be an alternative for something free.
Enhance your regex with anchors. These will ascertain that the whole test string matches instead of a substring. The following code also assembles all match patterns of interest into a single regex pattern which will be used against each line of the target file:
Dim strall As String
strall = ""
For i = 0 To stra.Length - 1
If i > o Then
strall = strall & "|"
End If
strall = strall & stra(i)
Console.WriteLine(" " & stra(i))
Next
strall = "^(" & strall & ")$"
Dim regexall As New Regex(strall, RegexOptions.ExplicitCapture)
'...
Dim linecount = 0
Dim match As Match = regexall.Match(lines(i)) '... was 'lines(1)', probably a typo
If match.Success Then
'...
this code is working with me thanks for all
Public Function countlines(ByVal st As String) As Integer
Dim count As Integer
Dim linecount As Integer = 0
Dim substrings() As String = Regex.Split(st, " ")
Dim stt() As String = {23, 7, 3}
For i = 0 To stt.Length - 1
'For j = 0 To substrings.Length - 1
'Console.WriteLine(substrings(0))
'For i = 0 To substrings.Length - 1
'Console.Write(substrings(i))
Dim matchQuery = From word In substrings Where word.ToLowerInvariant() = stt(i).ToLowerInvariant() Select word
' ' Count the matches.
count = matchQuery.Count()
Console.WriteLine("count=" & count)
If count > 0 Then
linecount += 1
Else
Console.WriteLine(" linecount=" & linecount)
End If
Next
Console.WriteLine("linecount= " & linecount)
Return linecount
End Function
Sub Main()
Dim lines() As String = IO.File.ReadAllLines("e:\ii.txt")
For Each line As String In lines
countlines(line)
Next
End Sub

Converting an Excel list according to row indexes

I'm trying to convert a list in Excel VBA as follows:
My original list in the one colored in grey. It shows a sequence.
I want to generate the list on the right according to each number location.
For example:
3 is second in the left list so 2 is on the third location in the right list;
6 is fourth in the left list so 4 is on the sixth location in the right list ...
I tried using 'For' loops in VBA, but it's getting a bit long and complex, is there a way to do it by using arrays in VBA?
A formula can easily achieve this. Assuming data is in A1:A8, in B1 and copied down:
=MATCH(ROW(),A$1:A$8,0)
This will work, just set the first, last and ranges as needed.
Private Sub cbSort_Click()
Dim wArray As Variant, dArray As Variant
Dim first As Integer, last As Integer
Dim i As Integer, j As Integer
first = 1
last = 8
Set wArray = Range("A" & first & ":A" & last)
ReDim dArray(1 To last - first + 1, 1 To 1)
j = 1
For i = first To last
dArray(wArray(i, 1), 1) = j
j = j + 1
Next i
Range("B" & first & ":B" & last) = dArray
End Sub
Option Explicit
Sub Main()
Dim source As Range
On Error GoTo ErrTransformIt
Set source = Application.InputBox(prompt:="Source", Type:=8)
TransformIt source
Exit Sub
ErrTransformIt:
MsgBox Err.Description
End Sub
Private Sub TransformIt(ByVal source As Range)
Dim target As Range
Dim c As Range
Dim i As Integer
Dim firstRow As Long
firstRow = source(1).Row
i = 1
For Each c In source.Cells
Set target = ActiveSheet.Cells(firstRow + c.Value - 1, c.Column + 1)
If target.Value <> "" Then
MsgBox "Target is already used by [" & target.Value & "]", vbExclamation
Exit Sub
End If
target.Value = i
i = i + 1
Next c
End Sub

How to count integers that are greater than a number and then search array to correlate the number to a name

I have two arrays (_intCholesterol and _strPatientNames). What I am trying to accomplish is to look through an array and count the number of integers in the array that are larger than 200, which I have already done below. But additionally I need to search another array (_strPatientName) and correlate the number that was found to be above 200, to a name. Such as Bob 272. And then write the name and high number to a file. How do accomplish the search and correlation?
Dim intCount As Integer = 0
Dim objWriter As New IO.StreamWriter("e:/consult.txt")
For Each intCholesterolLevel In _intCholesterolLevel
If intCholesterolLevel > 200 Then
intCount += 1
End If
Next
lblOutliers.Visible = True
lblOutliers.Text = "There were " & intCount & " people with levels above 200"
The code I used ended up being:
Dim objWriter As New IO.StreamWriter("E:\consult.txt")
' See if file exists.
If IO.File.Exists("E:\consult.txt") Then
' Run loop for numbers over 200 and write the file.
For intCholesterolIndex = 0 To (_intCholesterolLevel.Length - 1)
If _intCholesterolLevel(intCholesterolIndex) > 200 Then
objWriter.WriteLine(_strPatientName(intCholesterolIndex))
objWriter.WriteLine(_intCholesterolLevel(intCholesterolIndex))
End If
Next
Else
MsgBox("The file is not available, try again")
End If
objWriter.Close()
I think what you may be looking for is a Dictionary instead of 2 arrays.
Possible example
Dim cholesterolLevels As New Dictionary(Of String, Integer)
cholesterolLevels.Add("Bob", 272)
cholesterolLevels.Add("John", 190)
cholesterolLevels.Add("Joe", 205)
cholesterolLevels.Add("Bill", 165)
For Each patient As KeyValuePair(Of String, Integer) In cholesterolLevels
Dim name As String = patient.Key
Dim level As Integer = patient.Value
If level > 200 Then
intCount += 1
objWriter.WriteLine(name & " - " & level)
End if
Next
objWriter.Flush()
objWriter.Close()
If intCount > 0
lblOutliers.Visible = True
lblOutliers.Text = "There were " & intCount & " people with levels above 200"
End if

Resources