I have multiple files with names:
c123we_1014_A1_45333
c123we_1014_A2_45333
c123we_1014_A3_45333
What I need is to get only the third parameter and display it using a message box.
What I do is I get the third parameter and write it in text file.
For Each filelog In FileList
LogFile = Split(filelog, "~")(1)
Set otf = fso.OpenTextFile("C:\Data\" & LogFile, 1)
sFile = Split(LogFile, "_")
CurStep = sFile(3)
FileNameStep = LotId & "_" & "Step"
ScriptPath = Mid(ScriptFolder, 1, Len(ScriptFolder) - 8)
If Not fso.FileExists(ScriptFolder & "\" & FileNameStep & ".txt") Then
Set ctf = fso.CreateTextFile(ScriptFolder & "\" & FileNameStep & ".txt", True)
ctf.Close
End If
Set otf = fso.OpenTextFile(ScriptFolder & "\" & FileNameStep & ".txt", 8)
otf.Writeline "Current - " & CurStep
otf.Close
Next
My text file output will be as below:
Current - A1
Current - A2
Current - A3
I am stuck at how to display the content of text file using message box.
I have also tried using array instead write it to txt file which more simpler that using txt file. My code as below:
For Each filelog In FileList
LogFile = Split(filelog, "~")(1)
Set otf = fso.OpenTextFile("C:\Data\" & LogFile, 1)
l = 0
MsgBox FileList.Count
Do While l < FileList.Count
sFile = Split(LogFile, "_")
CurStep = sFile(4)
array.Add CurStep
l = l + 1
Loop
Next
MsgBox Join(array, vbNewLine)
But got error. The error is at MsgBox Join() line:
Error: Invalid procedure call or argument
After you have written the data to your text file you can close it and then follow these steps:
A. Open the file in Read mode again and set an object reference to it:
Set objFile = fso.OpenTextFile(ScriptFolder & "\" & FileNameStep & ".txt",1)
B. Read the contents of the file using the readall() method and store it in a variable:
tempData = objFile.readAll()
C. Close the file and Display the contents using 'Msgbox'
objFile.Close
MsgBox tempData
If you want to display the data in text file, line-by-line you can use the readline() method and modify step B to:
While not fso.atEndOfStream
tempData = fso.readline()
Msgbox tempData
Wend
Edit 2: For the second part of your question:
You should not use the word "array" as a variable name as it is a keyword in vbscript. Also, you do not add elements in an array using .Add as we are talking about arrays here not arraylists.
You can replace your code with the following:
Dim intCtr: intCtr=-1
Dim tempArr()
For Each filelog in FileList
LogFile = Split(filelog, "~")(1)
Set otf = fso.OpenTextFile("C:\Data\" & LogFile, 1)
l = 0
msgbox FileList.Count
do while l < FileList.Count
intCtr=intCtr+1
sFile = Split(LogFile, "_")
CurStep = sFile(4)
Redim preserve tempArr(intCtr)
tempArr(intCtr)=CurStep
l = l + 1
Loop
next
MsgBox Join(tempArr, vbNewLine)
Related
I want to do it with vba wscript.shell because copying files is faster and I want to copy files based on path or filename in excel cell based on the selection in column "E" and output the destination folder using "msoFileDialogFolderPicker"
I have sample code but need to change.
Sub copy()
xDFileDlg As FileDialog
xDPathStr As Variant
sn = Filter(Split(CreateObject("wscript.shell").exec("cmd /c dir C:\copy\*.* /b /s").stdout.readall, vbCrLf), "\")
'For j = 0 To UBound(sn)
'If DateDiff("d", FileDateTime(sn(j)), Date) > 30 Then sn(j) = ""
'Next
sn = Filter(sn, "\")
For j = 0 To UBound(sn)
FileCopy sn(j), "C:\destcopy" & Mid(sn(j), 2)
Next
Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xDFileDlg.Title = "Please select the destination folder:"
If xDFileDlg.Show <> -1 Then Exit Sub
xDPathStr = xDFileDlg.SelectedItems.Item(1) & "\"
End Sub
Thanks
roy
Please, test the next code. It assumes that you need to select the destination folder for copying of all files there. Otherwise, some milliseconds saved by VBScript object mean too little against the necessary seconds to browse for each file destination folder to be copied. But, if this is what you want, I can easily adapt the code to do that:
Sub copyFiles()
Dim sh As Worksheet, lastR As Long, arrA, i As Long, k As Long
Dim fileD As FileDialog, strDestFold As String, FSO As Object
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row ' last row on A:A column
arrA = sh.Range("A2:E" & lastR).Value2 'place the range in an array for faster iteration
Set FSO = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select the destination folder!"
.AllowMultiSelect = False
If .Show = -1 Then
strDestFold = .SelectedItems.Item(1) & "\" 'select the destination folder
End If
End With
If strDestFold = "" Then Exit Sub 'in case of not selecting any folder
For i = 1 To UBound(arrA)
If UCase(arrA(i, 5)) = "V" Then 'copy the file only if a "V" exists in column E:E
If FSO.FileExists(arrA(i, 1)) Then 'check if the path in excel is correct
FSO.CopyFile arrA(i, 1), strDestFold, True 'copy the file (True, to overwrite the file if it exists)
k = k + 1
Else
MsgBox arrA(i, 1) & " file could not be found." & vbCrLf & _
"Please, check the spelling and correct the file full path!", vbInformation, _
"File does not exist..."
End If
End If
Next i
MsgBox "Copied " & k & " files in " & strDestFold, , "Ready..."
End Sub
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.
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.
I have multiple "datasheet" text files that are used with a program at work and need to harvest values from them and combine it all into a spreadsheet.
The text files are formatted as such:
[File]
DescText = "1756-IF16H 16 Channel Hart Analog Input Module";
CreateDate = 04-07-10;
CreateTime = 10:29;
Revision = 1.1;
HomeURL = "http://www.ab.com/networks/eds/XX/0001000A00A30100.eds";
[Device]
VendCode = 1;
VendName = "Allen-Bradley";
ProdType = 10;
ProdTypeStr = "Multi-Channel Analog I/O with HART";
ProdCode = 163;
MajRev = 1;
MinRev = 1;
ProdName = "1756-IF16H/A";
Catalog = "1756-IF16H/A";
Icon = "io_brown.ico";
The Tags are consistent through all the files and each lines ends with a semicolon [ ; ] so I'm assuming this should be pretty easy. I need to pull "DescText","VendCode","ProdType","MajRev","MinRev",and"ProdName" into separate columns.
There are about 100 individual data files, each with a nonsensical filename, so I'm looking to have the macro just go through and open each one in the folder.
Thanks for the help, here is the solution I came up with for this specific problem
Sub OpenFiles()
Dim MyFolder As String
Dim MyFile As String
MyFolder = "[directory of files]"
MyFile = Dir(MyFolder & "\*.txt")
Dim filename As String
Dim currentrow As Integer: currentrow = 2
Do While Myfile <> "" 'This will go through all files in the directory, "Dir() returns an empty string at the end of the list
'For i = 1 To 500 'this was my debug loop to only go through the first 500 files at first
filename = MyFolder & "\" & MyFile 'concatinates directory and filename
Open filename For Input As #1
Do Until EOF(1) 'reads the file Line by line
Line Input #1, textline
'Text = Text & textline
If textline = "" Then 'error handler, if line was empty, ignore
Else
Dim splitline() As String
splitline() = Split(textline, "=", -1, vbTextCompare)
'because of how my specific text was formatted, this splits the line into 2 strings. The Tag is in the first element, the data in the second
If IsError(splitline(0)) Then
splitline(0) = ""
End If
Select Case Trim(splitline(0)) 'removes whitespace
Case "DescText"
currentrow = currentrow + 1
'files that didn't have a description row, resulted in empty rows in the spreadsheet.
ActiveSheet.Range("A" & currentrow).Cells(1, 1).Value = splitline(1)
Case "Revision"
ActiveSheet.Range("B" & currentrow).Cells(1, 1).Value = splitline(1)
Case "ProdCode"
ActiveSheet.Range("C" & currentrow).Cells(1, 1).Value = splitline(1)
Case "ProdType"
ActiveSheet.Range("D" & currentrow).Cells(1, 1).Value = splitline(1)
'...etc. etc... so on for each "tag"
End Select
End If
Loop
Close #1
MyFile = Dir() 'reads filename of next file in directory
'currentrow = currentrow + 1
'Next i
Loop
End Sub
here how I would solve the complete task:
Private Sub importFiles(ByVal pFolder As String)
' create FSO
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
' create folder
Dim oFolder As Object
Set oFolder = oFSO.getFolder(pFolder)
' go thru the folder
Dim oFile As Object
For Each oFile In oFolder.Files
' check if is a text file
If UCase(Right(oFile.Name, 4)) = ".TXT" Then
Debug.Print "process file: " & oFolder.Path & "\" & oFile.Name
readFile oFolder.Path & "\" & oFile.Name
End If
Next
' clean up
Set oFolder = Nothing
Set oFSO = Nothing
End Sub
Private Sub readFile(ByVal pFile As String)
' get new file handle
Dim hnd As Integer
hnd = FreeFile
' open file
Open pFile For Input As hnd
Dim sContent As String
Dim sLine As String
' read file
Do Until EOF(hnd)
Line Input #hnd, sLine
sContent = sContent & sLine
Loop
' close file
Close hnd
' extract requiered data
Debug.Print getValue(sContent, "ProdName")
Debug.Print getValue(sContent, "DescText")
End Sub
Private Function getValue(ByVal pContent As String, ByVal pValueName As String) As String
Dim sRet As String
sRet = ""
If InStr(pContent, pValueName) Then
pContent = Mid(pContent, InStr(pContent, pValueName) + Len(pValueName) + 2)
sRet = Left(pContent, InStr(pContent, ";") - 1)
sRet = Trim(sRet)
End If
getValue = sRet
End Function
Overall the solution contains 3 different procedures:
importFiles reads the content of a given directory (which has to be handed over as parameter) and if it finds a .txt file it calls readFile() and passes the full path of the file to it
readFile() opens the text file and stores the content in a string variable. After this is done it calles getValue for each value you are interessted in.
getValue analyses the given content and extractes the given value.
Simply adjust the calls of getValue() so that you get all values you are interessted in and store them instead of showing via debug.print and call the first procedure with the right directory like importFiles "C:\Temp"
Hiya Guys I have a text file with locations of files I'm looking for a way to read the text file and then use those locations as a source location and copy the files to a seperate destination.
I've been playing around and have seen about dynamic arrays but cant seem to understand how to put the contents of the array into variables to read as source location.
example of what I have done so far
Dim TxtFile
dim strDestinationFolder
strDestinationFolder = "\\SERVER\DESTLOGS"
TxtFile = "c:\windows\temp\SOFTWARELOG.txt"
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
Dim f: Set f = fso.OpenTextFile(TxtFile)
Do Until f.AtEndOfStream
WScript.Echo "PSTLocation: " & f.ReadLine ; I can read each line here in the txt file
fso.CopyFile strDestinationFolder, f.REadline
Loop
I've also tried playing with, but not sure where to start though it looks the most reliable?
Const ForReading = 1
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile _
(TxtFile, ForReading)
Do Until objTextFile.AtEndOfStream
strNextLine = objTextFile.Readline
arrServiceList = Split(strNextLine , ",")
WScript.Echo "Server: " & arrServiceList(0)
WScript.Echo "Service: " & objTextFile
For k = 1 to UBound(arrServiceList)
WScript.Echo vbTab & "Service: " & arrServiceList(i)
Next
Loop
Any Guidance please as to what is the best way I should go about this with vbs.
Thanks
WScript.Echo "PSTLocation: " & f.ReadLine
fso.CopyFile strDestinationFolder, f.REadline
Your code echoes one line read from the file, and then tries to copy the destination folder to the next line read from the file.
If you want to do more than one thing with a line read from a file you need to assign the read line to a variable and then use that variable. Also, you need to switch the arguments of the CopyFile method. Source comes first, then destination. Plus, if you want the destination to be a folder, it needs a trailing backslash (otherwise you'd try to overwrite a folder with a file, which raises an error).
Do Until f.AtEndOfStream
line = Trim(f.ReadLine)
WScript.Echo "PSTLocation: " & line
If fso.FileExists(line) Then fso.CopyFile line, strDestinationFolder & "\"
Loop
The Trim() accounts for spurious leading/trailing spaces in the read line, and it's always a good idea to check if a file actually exists before you try to do anything with it.
Edit: For detecting an existing destination file and appending a running number to the file name try something like this:
basename = fso.GetBaseName(line)
extension = fso.GetExtensionName(line)
destinationFile = fso.BuildPath(strDestinationFolder, basename & "." & extension)
i = 1
Do While fso.FileExists(destinationFile)
filename = basename & i & "." & extension
destinationFile = fso.BuildPath(strDestinationFolder, filename)
i = i + 1
Loop
fso.CopyFile line, destinationFile