I'm trying to create a macro that reads each *.txt file from a folder, and if the modification date matches the current one, copy the contents into a worksheet of the *.xls file. I've been checking a lot of the codes you have been sharing here, but I just can't make it work.
When debbuging, at the 8th line, I get an error:
438: Object doesn't support this property or method
Sub GetSAPfiles()
Dim Cont As Integer
Dim RootDir As String
RootDir = "\HOME\SAP\dir\"
SAPfile = Dir(RootDir)
Set SAPfile = CreateObject("Scripting.FileSystemObject")
Set SF = SAPfile.GetFile(RootDir + SAPfile)
Do While SAPfile <> ""
Dim ObjDate, CurrDate
CurrDate = Format(Now(), "MM/DD/YYYY")
ObjDate = Format(file.DateLastModified, "MM/DD/YYYY")
If CurrDate = ObjDate Then
Cont = Cont + 1
Dim TxtFl, Txt
Set TxtFl = SAPfile.OpenTextFile(RootDir + SAPfile)
Txt = TxtFl.ReadLine
ActiveSheet.Cells(Cont, "A").Value = Txt
ArchTxt.Close
End If
SAPfile = Dir(RootDir)
Loop
End Sub
Try something like this instead, use the command prompt to get an array of files and loop through them using the FSO to check the modified date and read the text into the next blank cell in column A:
Sub SO()
RootDir$ = "\HOME\SAP\dir\"
For Each x In Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR " & RootDir & "*.* /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
With CreateObject("Scripting.FileSystemObject")
If DateValue(.GetFile(RootDir & x).DateLastModified) = Date Then _
Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = .OpenTextFile(RootDir & x, 1).ReadAll
End With
Next x
End Sub
Related
I trying to write much larger code to email a list of files in a TAR file and then send it in an email but the last thing i am struggling with is the actual listing of the contents of the TAR file. the code I have tried so far is:
Public r As Long
Sub Test()
Dim strPath As String
Dim sh, n, x, i
'Change Path To Suit
'strPath = ThisWorkbook.Path & "\"
strPath = "H:\99 - Temp\"
Set sh = CreateObject("Shell.Application")
x = GetFiles(strPath, "*.TAR", True)
r = 7
For Each i In x
Set n = sh.NameSpace(i) <----------
Recur sh, n
Next i
End Sub
Sub Recur(sh, n)
Dim i, subn, x As Long, p As Long
For Each i In n.Items
If i.isfolder Then
Set subn = sh.NameSpace(i)
Recur sh, subn
Else
p = LastPos(i.Path, "\")
Debug.Print Mid(i.Path, p + 1)
'Cells(r, 1) = Mid(i.Path, p + 1)
r = r + 1
End If
Next i
End Sub
Function GetFiles(StartPath As String, FileType As String, SubFolders As Boolean) As Variant
StartPath = StartPath & IIf(Right(StartPath, 1) = "\", vbNullString, "\")
GetFiles = Split(Join(Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & StartPath &
FileType & """ " & IIf(SubFolders, "/S", vbNullString) & " /B /A:-D").StdOut.ReadAll, vbCrLf), ":"),
"#"), "#")
End Function
Function LastPos(strVal As String, strChar As String) As Long
LastPos = InStrRev(strVal, strChar)
End Function
But I can a runtime error '-2147467259 (80004005)':
Method 'NameSpace of Object 'IShellDispatch6' failed
so I tried this one:
Sub test99()
Dim n As Variant
Set sh = CreateObject("shell.application")
Set n = sh.NameSpace("H:\99 - Temp\test.TAR")
For Each i In n.Items <-------------
Debug.Print i.Path
Next
End Sub
which returns another run-time error 91:
Object variable or with block variable not set.
I am comfortable with VBA but really struggling to integrate shell.
ideally the end goal is to get the file open window, select the TAR file that I need read (it's not always in the same folder so need it flexible) and then list the files in the TAR.
Thank you
Using ShellRun concept from here: Capture output value from a shell command in VBA?
Working on Win10
Sub tester()
Dim p, s, col, e
p = "C:\Blah\Temp\Temp.tar"
Set col = ShellOutput("tar -tf """ & p & """")
Debug.Print col.Count; " entries returned"
Debug.Print "--------------------"
For Each e In col
Debug.Print e
Next e
End Sub
'Run a shell command, returning the output as a collection of lines
Public Function ShellOutput(sCmd As String) As Collection
Dim sLine, col As Collection
Set col = New Collection
With CreateObject("WScript.Shell").Exec(sCmd).StdOut
While Not .AtEndOfStream
sLine = .ReadLine
If sLine <> "" Then col.Add sLine
Wend
End With
Set ShellOutput = col
End Function
I have code which compares two folders (textFiles & ExcelFiles), to find if all textFiles are converted to Excel. If not, it calls a function that does this. Everything works well, but when I open the Excel file, the format may change from a row to another in the same column.
This is my code:
Sub LookForNew()
Dim dTxt As String, dExcel As String, key As String
Dim i As Integer
Dim oFileExcel, tFileExl, oFileExl, fso, filsTxt, filsExcel, fil, exl
Set fso = CreateObject("Scripting.FileSystemObject")
Set filsTxt = fso.GetFolder("C:\txtFiles").Files
Set filsExcel = fso.GetFolder("C:\excelFiles").Files
Set oFileExcel = CreateObject("Scripting.Dictionary")
Set tFileExl = CreateObject("Scripting.Dictionary")
Set oFileExl = CreateObject("Scripting.Dictionary")
i = 0
For Each fil In filsTxt
dTxt = fil.Name
dTxt = Left(dTxt, InStr(dTxt, ".") - 1)
For Each exl In filsExcel
dExcel = exl.Name
dExcel = Left(dExcel, InStr(dExcel, ".") - 1)
key = CStr(i)
oFileExcel.Add dExcel, "key"
i = i + 1
Next exl
If Not (oFileExcel.Exists(dTxt)) Then
Call tgr
End If
Next fil
Set fso = Nothing
End Sub
Sub tgr()
Const txtFldrPath As String = "C:\txtFiles"
Const xlsFldrPath As String = "C:\excelFiles"
Dim CurrentFile As String: CurrentFile = Dir(txtFldrPath & "\" & "*.txt")
Dim strLine() As String
Dim LineIndex As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
While CurrentFile <> vbNullString
LineIndex = 0
Close #1
Open txtFldrPath & "\" & CurrentFile For Input As #1
While Not EOF(1)
LineIndex = LineIndex + 1
ReDim Preserve strLine(1 To LineIndex)
Line Input #1, strLine(LineIndex)
'STRIP TABS OUT AND REPLACE WITH A SPACE!!!!!
strLine(LineIndex) = Replace(strLine(LineIndex), Chr(9), Chr(32))
Wend
Close #1
With ActiveSheet.Range("A1").Resize(LineIndex, 1)
.Value = WorksheetFunction.Transpose(strLine)
'DEFINE THE OPERATION FULLY!!!!
.TextToColumns Destination:=.Cells(1), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, Comma:=False, Space:=False, _
Other:=True, OtherChar:="|"
End With
ActiveSheet.UsedRange.EntireColumn.AutoFit
ActiveSheet.Copy
ActiveWorkbook.SaveAs xlsFldrPath & "\" & Replace(CurrentFile, ".txt", ".xlsx"), xlOpenXMLWorkbook
ActiveWorkbook.Close False
ActiveSheet.UsedRange.ClearContents
CurrentFile = Dir
Wend
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
This is the picture:
The General format cell changes for some records and becomes a number exp: 4'927'027.00 should be 4927027 like the others.
this is the text file lines
And I want to put a msgBox when there's no Files to convert in "LookForNew" function, but I don't know where.
Question 1: I open the Excel file, the format may change from a row to another in the same column.
Answer: The problem probable lies in your text file. Note what row ,column, and value that isn't formatted properly. Next go to that line and column in your text file. You'll most likely see 4,927,027 or "4927027". In either case Excel might mistake it for a string value.
Question 2: I want to put a msgBox when there's no Files to convert in "LookForNew" function, but I don't know where.
Put a counter in your If Files Exist. You should have your MsgBox after you exit your file loop. - Next fil
This line is miss leading:
oFileExcel.Add dExcel, "key"
correct syntax
dictionary.add key, value
Keys are unique identifiers. Before you add a key to a dictionary you should test to see if the key exist
If not oFileExcel.Exists dExcel then oFileExcel.Add dExcel, ""
Values are references to objects or values.
This line adds the exl file object to oFileExcel dictionary
If not oFileExcel.Exists dExcel then oFileExcel.Add dExcel, exl
This line retrieves the value
Set exl = oFileExcel("SomeKey")
The error is being thrown because you are adding the same key twice. The key values are the name of the Excel file without an extension. Example.xls and Example.xlsx will produce the same key.
That being said, there is no need to use a dictionary. Or to do a file loop in tgr().
I better approach would be
Sub Main
For each textfile
basename = get text file basename
xlfile = xlFileDirectory + baseFileName + excel file extension
if not xlfile Exists then call CreateExcelFromTxt f.Path, xlFileName
End Sub
Sub CreateExcelFromTxt( txtFile, xlFileName)
Open txtFile
Build strLine
Create Excel -> xlFileName
Add strLine to xlFileName
run TextToColumns
End Sub
Here is a starter template
Sub LookForNew()
Const xlFileDirectory = "C:\excelFiles\"
Const txtFileDirectory = C:\txtFiles\"
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim fso, fld , f, xlFileName
Set fso = WScript.CreateObject("Scripting.Filesystemobject")
Set fld = fso.GetFolder(txtFileDirectory)
Set txtFiles = fso.GetFolder(txtFileDirectory).Files
For Each f In txtFiles
baseFileName = Left(f.Name,InStrRev(f.Name,".")-1)
xlFilePath = xlFileDirectory & baseFileName & ".xlsx"
If Not fso.FileExists(xlFilePath ) Then CreateExcelFromText f.Path, xlFileName
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub CreateExcelFromText(txtFileName, xlFileName)
End Sub
This code uses Dir to get sub-dirs. Each sub-dir needs to have its xls files processed. After it finishes processing the first batch of xls, I get invalid procedure call or argument. I am guessing when I pass dirLook to the function it creates a copy? Please assist. I need to move on to the next sub-dir.
dirLook = dir(strDir, vbDirectory)
Do While dirLook <> ""
If dirLook <> "." And dirLook <> ".." Then
If (GetAttr(strDir & adir) And vbDirectory) = vbDirectory Then
'Perform action on folder here
loopXls (dirLook)
Debug.Print dirLook
End If
End If
dirLook = dir
Loop
loopXls:
Function loopXls(dirStr As String)
Dim count As Integer
Dim strFilename As String
Dim strPath As String
Dim wbkTemp As Workbook
strPath = "C:\Users\pmevi\Documents\L7\L7_Master_Book\Input\" & dirStr & "\"
strFilename = dir(strPath & "*.xls")
Do While Len(strFilename) > 0
Set wbkTemp = Workbooks.Open(strPath & strFilename)
'
' do your code with the workbook
'
' save and close it
wbkTemp.Close True
count = count + 1
strFilename = dir
Loop
Debug.Print (count)
End Function
EDIT2
I am attemping to load each dir into an array, but for some reason when I loop through array I only see 3 folders instead of 5.
Dim dirs(5) As String
Dim i As Integer
Dim endNum As Integer
endNum = 4
dirLook = dir(strDir, vbDirectory)
For i = 0 To endNum
dirs(i) = dirLook
dirLook = dir
Next i
For i = 0 To endNum
Debug.Print (dirs(i))
Next i
output:
3-10-14
3-11-14
3-12-14
expected:
3-10-14
3-11-14
3-12-14
3-13-14
3-14-14
Edit3
Found issue to array. 2 indexes are used for "." and ".."
It's not exactly clear from the code, but if the code above is in the loopXls method, making this a recursive function then the problem is that you cannot use the Dir function recursively, as stated here, towards the bottom.
The answer here include shows an example class for recursing with the Dir function.
Every week I separate a long PowerPoint file into separate files. The files must be in PowerPoint format, and contain only the slides that are contained in the 'sections' from the PowerPoint file.
I need to:
1) Scan to see the number of slides in a given section
2) Make a file containing the slides within that section
3) Name that file the same as the name of the section, and save it in the same directory as the source file.
4) Repeat the process for subsequent sections.
5) Do this without damaging the original file.
I've located code (http://www.pptfaq.com/FAQ01086_Break_a_presentation_up_into_several_smaller_presentations.htm) that can break the file into many parts, but only by the number of files requested per file. I found some other helpful references here: http://skp.mvps.org/2010/ppt001.htm
I have coded in Basic and a number of easy gaming scripting languages. I need help understanding how this is done in VBA.
Since you do this very often, you should make an Add-In for this. The idea is to create copies of the presentation up to the number of sections in it, then open each one and delete the other sections and save.
Create blank presentation with macros enabled (*.pptm) and possibly add Custom UI button to call SplitIntoSectionFiles
Test and when satisfy, save as PowerPoint Add-In (*.ppam). Don't delete the pptm file!
Assuming that all are pptx files you are dealing with, you can use this code. It opens the splited pptx files in background, then remove irrelevant sections and save, close. If all goes well you get a message box.
Private Const PPT_EXT As String = ".pptx"
Sub SplitIntoSectionFiles()
On Error Resume Next
Dim aNewFiles() As Variant, sPath As String, i As Long
With ActivePresentation
sPath = .Path & "\"
For i = 1 To .SectionProperties.Count
ReDim Preserve aNewFiles(i)
' Store the Section Names
aNewFiles(i - 1) = .SectionProperties.Name(i)
' Force Save Copy as pptx format
.SaveCopyAs sPath & aNewFiles(i - 1), ppSaveAsOpenXMLPresentation
' Call Sub to Remove irrelevant sections
RemoveOtherSections sPath & aNewFiles(i - 1) & PPT_EXT
Next
If .SectionProperties.Count > 0 And Err.Number = 0 Then MsgBox "Successfully split " & .Name & " into " & UBound(aNewFiles) & " files."
End With
End Sub
Private Sub RemoveOtherSections(sPPT As String)
On Error Resume Next
Dim oPPT As Presentation, i As Long
Set oPPT = Presentations.Open(FileName:=sPPT, WithWindow:=msoFalse)
With oPPT
' Delete Sections from last to first
For i = .SectionProperties.Count To 1 Step -1
' Delete Sections that are not in the file name
If Not InStr(1, .Name, .SectionProperties.Name(i), vbTextCompare) = 1 Then
' Delete the Section, along with the slides associated with it
.SectionProperties.Delete i, True
End If
Next
.Save
.Close
End With
Set oPPT = Nothing
End Sub
Read about Custom UI if you don't have experience creating you own ribbon tab: msdn and use the "Office Custom UI Editor", I would use imageMso "CreateModule" for the button.
None of the proposed routines actually works, so I wrote mine from scratch:
Sub Split()
Dim original_pitch As Presentation
Set original_pitch = ActivePresentation
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
With original_pitch
.SaveCopyAs _
FileName:=fso.BuildPath(.Path, fso.GetBaseName(.Name) & ".pptx"), _
FileFormat:=ppSaveAsOpenXMLPresentation
End With
Dim i As Long
For i = 1 To original_pitch.SectionProperties.Count
Dim pitch_segment As Presentation
Set pitch_segment = Presentations.Open(Replace(original_pitch.FullName, "pptm", "pptx"))
section_name = pitch_segment.SectionProperties.Name(i)
For k = original_pitch.SectionProperties.Count To 1 Step -1
If pitch_segment.SectionProperties.Name(k) <> section_name Then pitch_segment.SectionProperties.Delete k, True
Next k
With pitch_segment
.SaveCopyAs _
FileName:=fso.BuildPath(.Path, original_pitch.SectionProperties.Name(i) & ".pptx"), _
FileFormat:=ppSaveAsOpenXMLPresentation
.Close
End With
Next i
MsgBox "Split completed successfully!"
End Sub
I could not get the above code to work.
However this is simpler and does work:
Sub SplitToSectionsByChen()
daname = ActivePresentation.Name
For i = 1 To ActivePresentation.SectionProperties.Count
For j = ActivePresentation.SectionProperties.Count To 1 Step -1
If i <> j Then ActivePresentation.SectionProperties.Delete j, True
Next j
ActivePresentation.SaveAs ActivePresentation.SectionProperties.Name(1)
ActivePresentation.Close
Presentations.Open (daname)
Next i
End Sub
I have edited fabios code a bit to look like this. And this works well for me in my PC
Option Explicit
Sub Split()
Dim original_File As Presentation
Dim File_Segment As Presentation
Dim File_name As String
Dim DupeName As String
Dim outputFname As String
Dim origName As String
Dim lIndex As Long
Dim K As Long
Dim pathSep As String
pathSep = ":"
#If Mac Then
pathSep = ":"
#Else
pathSep = "/"
#End If
Set original_File = ActivePresentation
DupeName = "TemporaryFile.pptx"
DupeName = original_File.Path & pathSep & DupeName
original_File.SaveCopyAs DupeName, ppSaveAsOpenXMLPresentation
origName = Left(original_File.Name, InStrRev(original_File.Name, ".") - 1)
For lIndex = 1 To original_File.SectionProperties.Count
If original_File.SectionProperties.SlidesCount(lIndex) > 0 Then
Set File_Segment = Presentations.Open(DupeName, msoTrue, , msoFalse)
File_name = File_Segment.SectionProperties.Name(lIndex)
For K = original_File.SectionProperties.Count To 1 Step -1
If File_Segment.SectionProperties.Name(K) <> File_name Then
Call File_Segment.SectionProperties.Delete(K, 1)
End If
Next K
outputFname = pathSep & origName & "_" & original_File.SectionProperties.Name(lIndex) & "_" & Format(Date, "YYYYMMDD")
With File_Segment
.SaveAs FileName:=.Path & outputFname & ".pptx", FileFormat:=ppSaveAsOpenXMLPresentation
.Close
End With
Set File_Segment = Nothing
End If
Next
Set original_File = Nothing
Kill DupeName
MsgBox "Split completed successfully!"
End Sub
This works for me (except for the filename):
Option Explicit
Sub ExportSlidesAsPresentations()
Dim oPres As Presentation
Dim sSlideOutputFolder As String
Set oPres = ActivePresentation
sSlideOutputFolder = oPres.Path & "\"
'Export all the slides in the presentation
Call oPres.PublishSlides(sSlideOutputFolder, True, True)
Set oPres = Nothing
End Sub
I need to open a file whose full filename I do not know.
I know the file name is something like.
filename*esy
I know definitely that there's only one occurrence of this file in the given directory.
filename*esy is already a "shell ready" wildcard & if thats alway the case you can simply;
const SOME_PATH as string = "c:\rootdir\"
...
Dim file As String
file = Dir$(SOME_PATH & "filename*esy" & ".*")
If (Len(file) > 0) Then
MsgBox "found " & file
End If
Just call (or loop until empty) file = Dir$() to get the next match.
There is an Application.FileSearch you can use (see below). You could use that to search for the files that match your pattern. This information taken from here.
Sub App_FileSearch_Example()
With Application.FileSearch
.NewSearch
.LookIn = "c:\some_folder\"
.FileName = "filename*esy"
If .Execute(SortBy:=msoSortByLastModified, SortOrder:=msoSortOrderDescending) > 0 Then
For i1 = 1 To .FoundFiles.Count
' do something with matched file(s)
Next i1
End If
End With
End Sub
If InStr(sFilename, "filename") > 0 and InStr(sFilename, "esy") > 0 Then
'do somthing
end if
Or you can use RegEx
Dim RE As Object, REMatches As Object
Set RE = CreateObject("vbscript.regexp")
With RE
.MultiLine = False
.Global = False
.IgnoreCase = True
.Pattern = "filename(.*)esy"
End With
Set REMatches = RE.Execute(sFilename)
REMatches(0) 'find match
I was trying this question as a function. This is the solution that ended up working for me.
Function fileName(path As String, sName As String, ext As String) As Variant
'path is Full path from root. Can also use path = ActiveWorkbook.path & "\"
'sName is the string to search. ? and * are wildcards. ? is for single char
'example sName = "book?" or sName ="March_*_2014*"
'ext is file extention ie .pdf .xlsm .xls? .j*
Dim file As Variant 'Store the next result of Dir
Dim fname() As String 'Dynamic Array for result set
ReDim fname(0 To 0)
Dim i As Integer ' Counter
i = 0
' Use dir to search and store first result
fname(i) = path & Dir(path & "\" & sName & ext)
i = i + 1
'Load next result
file = Dir
While file <> "" 'While a file is found store that file in the array
ReDim Preserve fname(0 To i) As String
fname(i) = path & file
file = Dir
Wend
fileName = Application.Transpose(fname) 'Print out array
End Function
This works for me as a single or array function.
If you know that no other file contains "filename" and "esy" in that order then you can simply use
Workbooks.Open Filename:= "Filepath\filename*esy.*"
Or if you know the number of missing characters then (assuming 4 characters unknown)
Workbooks.Open Filename:= "Filepath\filename????esy.*"
I use this method to run code on files which are date & timestamped to ignore the timestamp part.