I created the following macro to open all ppt files in a certain map
Sub openAllPPT()
Dim strCurrentFile As String
Dim strFileSpec As String
strFileSpec = "C:\Documents and Settings\aa471714\Desktop\Nieuwe map*.ppt"
strCurrentFile = Dir$(strFileSpec)
While Len(strCurrentFile) > 0
Presentations.Open (strCurrentFile)
strCurrentFile = Dir$
Wend
End Sub
When I run it I do see anything opening up though. Anybody clue on what I'm missing?
Dir returns only the file name, not the full path to the file.
Try this instead:
Sub openAllPPT()
Dim strCurrentFile As String
Dim strFileSpec As String
Dim strDirectory As String
strDirectory = "C:\Documents and Settings\aa471714\Desktop\"
strFileSpec = "Nieuwe map*.ppt"
strCurrentFile = Dir$(strDirectory & strFileSpec)
While Len(strCurrentFile) > 0
'Presentations.Open (strDirectory & strCurrentFile)
Debug.Print strDirectory & strCurrentFile
strCurrentFile = Dir$
Wend
End Sub
Related
I have many .doc documents located in many subfolders and I would like to covert them to .docx
I was opening each file and saving it but there are too many of them, so I thought there must be a better and a faster way. I found online some VBA code but none seem to work.
First VBA code:
Sub TranslateDocIntoDocx()
Dim objWordApplication As New Word.Application
Dim objWordDocument As Word.Document
Dim strFile As String
Dim strFolder As String
strFolder = "H:\Vanhuspalvelut\Kotihoito\Tammelan_kotihoito\TURVALLISUUS\Pelastussuunnitelmaan_tuleva\TURVALLISUUS_SUUNNITELMA_2015"
strFile = Dir(strFolder & "*.doc", vbNormal)
While strFile <> ""
With objWordApplication
Set objWordDocument = .Documents.Open(FileName:=strFolder & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With objWordDocument
.SaveAs FileName:=strFolder & Replace(strFile, "doc", "docx"), FileFormat:=16
.Close
End With
End With
strFile = Dir()
Wend
Set objWordDocument = Nothing
Set objWordApplication = Nothing
End Sub
Second VBA code:
Sub ConvertBatchToDOCX()
Dim sSourcePath As String
Dim sTargetPath As String
Dim sDocName As String
Dim docCurDoc As Document
Dim sNewDocName As String
' Looking in this path
sSourcePath = "H:\Vanhuspalvelut\Kotihoito\Tammelan_kotihoito\TURVALLISUUS\Pelastussuunnitelmaan_tuleva\TURVALLISUUS_SUUNNITELMA_2015"
sTargetPath = "H:\Vanhuspalvelut\Kotihoito\Tammelan_kotihoito\TURVALLISUUS\Pelastussuunnitelmaan_tuleva\TURVALLISUUS_SUUNNITELMA_2015"
' Look for first DOC file
sDocName = Dir(sSourcePath & "*.doc")
Do While sDocName <> ""
' Repeat as long as there are source files
'Only work on files where right-most characters are ".doc"
If Right(sDocName, 4) = ".doc" Then
' Open file
Set docCurDoc = Documents.Open(FileName:=sSourcePath & sDocName)
sNewDocName = Replace(sDocName, ".doc", ".docx")
With docCurDoc
.SaveAs FileName:=sTargetPath & sNewDocName, _
FileFormat:=wdFormatDocumentDefault
.Close SaveChanges:=wdDoNotSaveChanges
End With
End If
' Get next source file name
sDocName = Dir
Loop
MsgBox "Finished"
End Sub
Any help would be much appreciated!
In both routines you have the same small mistake: You miss a Backslash between the path and the filename. Your Dir-Command will see the following command and therefore doesn't find anything:
Dir("H:\Vanhuspalvelut\Kotihoito\Tammelan_kotihoito\TURVALLISUUS\Pelastussuunnitelmaan_tuleva\TURVALLISUUS_SUUNNITELMA_2015*.doc", vbNormal
Either add the backslash at the end of the path definition:
strFolder = "H:\Vanhuspalvelut\Kotihoito\Tammelan_kotihoito\TURVALLISUUS\Pelastussuunnitelmaan_tuleva\TURVALLISUUS_SUUNNITELMA_2015\"
or put it into the Dir-command:
strFile = Dir(strFolder & "\*.doc", vbNormal)
I have never posted here before, so I thought I would give it a try. I have a macro that I have been using for over a year, and at beginning of the week it started to give me some problems. It will either just pull in the first slide of each powerpoint, or it will give me a Run-Time error "Slides (Unknown Member): Invalid request. Clipboard is empty or contains data which may not be pasted here."
The macro works fine if I just step through it using F8, the only time that I have issues is if I try to run it. It may be something super obvious, as I am pretty new to VBA. Thanks for the help!
Public Sub DoFiles()
Dim strFileName As String
Dim strFolderName As String
Dim objPresentation As Presentation
'set default directory here if needed
strFolderName = "Target Folder"
strFileName = Dir(strFolderName & "\*.ppt*")
Do While Len(strFileName) > 0
Set objPresentation = Presentations.Open(strFolderName & "\" &
strFileName)
On Error Resume Next
Dim i As Integer
For i = 1 To objPresentation.Slides.Count
objPresentation.Slides.Item(i).Copy
Presentations.Item(1).Slides.Paste
Presentations.Item(1).Slides.Item(Presentations.Item(1).Slides.Count).Design
= _
objPresentation.Slides.Item(i).Design
Next i
objPresentation.Close
strFileName = Dir
Loop
End Sub
Did Steve's suggestion work?
Public Sub DoFiles()
Dim strFileName As String
Dim strFolderName As String
strFolderName = "Target Folder"
strFileName = Dir(strFolderName & "\*.ppt*")
Do While Len(strFileName) > 0
ActivePresentation.Slides.InsertFromFile strFolderName & "\" & strFileName, ActivePresentation.Slides.Count
strFileName = Dir
Loop
End Sub
Thanks in advance for your help and comments.
I have the following problem, but I do not know if it is possible ... I am trying to rename PDF files that are in the folder C: \ ... I need to rename according to a worksheet that I have in excel that is ordered according to the pdf files .. I would like to rename with the spreadsheet data in excel?
I have a code that I researched but it does not search my database, but it asks me to enter the name of each file
Public Sub lsSelecionaArquivo()
Dim Caminho As String
Dim NomeBase As String
Caminho = InputBox("Informe o local dos arquivos a serem renomeados:", "Pasta", "C:\TEMP")
NomeBase = InputBox("Informe o local dos arquivos a serem renomeados:", "Renomear", "")
lsRenomearArquivos Caminho, NomeBase
End Sub
Public Sub lsRenomearArquivos(Caminho As String, NomeBase As String)
Dim FSO As Object, Pasta As Object, Arquivo As Object, Arquivos As Object
Dim Linha As Long
Dim lSeq As Long
Dim lNovoNome As String
Set FSO = CreateObject("Scripting.FileSystemObject")
If Not FSO.FolderExists(Caminho) Then
MsgBox "A pasta '" & Caminho & "' não existe.", vbCritical, "Erro"
Exit Sub
End If
lSeq = 1
Set Pasta = FSO.GetFolder(Caminho)
Set Arquivos = Pasta.Files
Cells(1, 1) = "De"
Cells(1, 2) = "Para"
Linha = 2
For Each Arquivo In Arquivos
Cells(Linha, 1) = UCase$(Arquivo.Path)
lNovoNome = Caminho & "\" & NomeBase & lSeq & Right(Arquivo, 4)
Name Arquivo.Path As lNovoNome
Cells(Linha, 2) = lNovoNome
lSeq = lSeq + 1
Linha = Linha + 1
Next
End Sub
For the renaming part, consider this.
Sub RenameFiles()
'Updateby20141124
Dim xDir As String
Dim xFile As String
Dim xRow As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = -1 Then
xDir = .SelectedItems(1)
xFile = Dir(xDir & Application.PathSeparator & "*")
Do Until xFile = ""
xRow = 0
On Error Resume Next
xRow = Application.Match(xFile, Range("A:A"), 0)
If xRow > 0 Then
Name xDir & Application.PathSeparator & xFile As _
xDir & Application.PathSeparator & Cells(xRow, "B").Value
End If
xFile = Dir
Loop
End If
End With
End Sub
https://www.extendoffice.com/documents/excel/2339-excel-rename-files-in-a-folder.html
Also, consider this.
Sub ListFiles()
Dim MyFolder As String
Dim MyFile As String
Dim j As Integer
MyFolder = "C:\DealerExam"
MyFile = Dir(MyFolder & "\*.*")
a = 0
Do While MyFile <> ""
a = a + 1
Cells(a, 1).Value = MyFile
MyFile = Dir
Loop
End Sub
This will list all the files in your directory starting in cell 'A1'
Thanks for the help
It is a bit tense to change language since I study Java and started doing VBA.
When I ran the code, I saw that it is necessary for the spreadsheet to have the old file name and the new one to insert the data, but there is no way to get it to just get the new data? And I've tried searching on how to make them as PDF without having to put the file extension in the worksheet.
Sorry for the questions ... I do not have much contact with VBA.
I thank you very much for helping me.
Sub RenameFiles()
Dim xDir As String
Dim xFile As String
Dim xRow As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = -1 Then
xDir = .SelectedItems(1)
xFile = Dir(xDir & Application.PathSeparator & "*")
Do Until xFile = ""
xRow = 0
On Error Resume Next
xRow = Application.Match(xFile, Range("A:A"), 0)
If xRow > 0 Then
Name xDir & Application.PathSeparator & xFile As _
xDir & Application.PathSeparator & Cells(xRow, "B").Value
End If
xFile = Dir
Loop
End If
End With
End Sub
Sub ListFiles()
Dim MyFolder As String
Dim MyFile As String
Dim j As Integer
MyFolder = "C:\Users\AnaWill\Desktop\Holerites Folha\Nova pasta"
MyFile = Dir(MyFolder & "\*.*")
a = 0
Do While MyFile <> ""
a = a + 1
Cells(a, 2).Value = MyFile
MyFile = Dir
Loop
End Sub
As in the Question: the task is to extract all files names from a folder, but the folder path needs to be hard coded into the macro, to prevent these dialog boxes asking me things and wasting my time.
I will not change this folder. It will be the same one until the end of time, and I want to extract the files names into the Excel column, starting from second row.
this is the folder I want to extract ALL files names from.
"C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst\"
this is my portion of code:
Option Explicit
Sub GetFileNames()
Dim axRow As Long ' inside the Sheet("Lista") row#
Dim xDirectory As String
Dim xFname As String ' name of the file
Dim InitialFoldr$
Dim start As Double
Dim finish As Double
Dim total_time As Double
start = Timer
ThisWorkbook.Sheets("Lista").Range("D2").Activate
InitialFolder = "C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst"
If Right(InitialFolder, 1) <> "\" Then
InitialFolder = InitialFolder & "\"
End If
Application.InitialFolder.Show
If InitialFolder.SelectedItems.Count <> 0 Then
xDirectory = .SelectedItems(1) & "\"
xFname = Dir(xDirectory, vbArchive)
' Dir's job is to return a string representing
' the name of a file, directory, or an archive that matches a specified pattern.
Do While xFname <> "" ' there is already xFname value (1st file name) assigned.
ActiveCell.Offset(xRow) = xFname
xRow = xRow + 1 ' następny xRow
xFname = Dir()
Loop
End If
End With
finish = Timer ' Set end time.
total_time = Round(finish - start, 3) ' Calculate total time.
MsgBox "This code ran successfully in " & total_time & " seconds", vbInformation
End Sub
this is the line that crushes:
If InitialFolder.SelectedItems.Count <> 0 Then
xDirectory = .SelectedItems(1) & "\"
And two more important questions in the .png file.
Please, respond to them as well - it's very important 4 me.
Or if U guys know any other method to do this faster just don't hesitate and share Your Code with me - I'll be very grateful.
Sub Files()
Dim sht As Worksheet
Dim strDirectory As String, strFile As String
Dim i As Integer: i = 1
Set sht = Worksheets("Sheet1")
strDirectory = "C:\Users\User\Desktop\"
strFile = Dir(strDirectory, vbNormal)
Do While strFile <> ""
With sht
.Cells(i, 1) = strFile
.Cells(i, 2) = strDirectory + strFile
End With
'returns the next file or directory in the path
strFile = Dir()
i = i + 1
Loop
End Sub
See example below
Public Sub Listpng()
Const strFolder As String = "C:\SomeFolder\"
Const strPattern As String = "*.png"
Dim strFile As String
strFile = Dir(strFolder & strPattern, vbNormal)
Do While Len(strFile) > 0
Debug.Print strFile '<- view this in Immediate window; Ctrl+g will take you there
strFile = Dir
Loop
End Sub
There's a couple of procedures I use depending on whether I want subfolders as well.
This loops through the folder and adds path & name to a collection:
Sub Test1()
Dim colFiles As Collection
Dim itm As Variant
Set colFiles = New Collection
EnumerateFiles "C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst\", "*.xls*", colFiles
For Each itm In colFiles
Debug.Print itm
Next itm
End Sub
Sub EnumerateFiles(ByVal sDirectory As String, _
ByVal sFileSpec As String, _
ByRef cCollection As Collection)
Dim sTemp As String
sTemp = Dir$(sDirectory & sFileSpec)
Do While Len(sTemp) > 0
cCollection.Add sDirectory & sTemp
sTemp = Dir$
Loop
End Sub
This second way goes through the subfolders as well returning path & name. For some reason if you change InclSubFolders to False it only returns the name - got to sort that bit out.
Sub Test2()
Dim vFiles As Variant
Dim itm As Variant
vFiles = EnumerateFiles_2("C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst\", "xls*")
For Each itm In vFiles
Debug.Print itm
Next itm
End Sub
Public Function EnumerateFiles_2(sDirectory As String, _
Optional sFileSpec As String = "*", _
Optional InclSubFolders As Boolean = True) As Variant
EnumerateFiles_2 = Filter(Split(CreateObject("WScript.Shell").Exec _
("CMD /C DIR """ & sDirectory & "*." & sFileSpec & """ " & _
IIf(InclSubFolders, "/S ", "") & "/B /A:-D").StdOut.ReadAll, vbCrLf), ".")
End Function
I got this code from somewhere in the net, and it works fine for me. However my experience is not enough to run it in all subfolders of the main one ("C:\Folder\"). I would appreciate any suggestion.
Sub check()
Dim strFolder As String
Dim strFile As String
strFolder = "C:\Folder\"
strFile = Dir(strFolder & "*.*")
Do While Len(strFile) > 0
If InStr(strFile, "xxx") > 0 Then
Name strFolder & strFile As strFolder & Replace(strFile, "xxx", "yyy")
End If
strFile = Dir()
Loop
End Sub
You're much better off using the System.IO namespace(you'll need to add the Imports statement for it), as there is a Directories.GetFiles method that allows for an option to search AllDirectories within your specified folder
Imports System.IO;
Sub Check()
Dim strFolder As String = "C:\Folder\"
Dim strFiles() As String = Directory.GetFiles(strFolder, "*.*", SearchOption.AllDirectories)
For Each strFile As String In strFiles
If strFile.Contains("xxx") Then
File.Move(strFolder & strFile, strFolder & strFile.Replace("xxx", "yyy"))
End If
Next
End Sub