company moved folders to onedrive however some people still using local drives, so I need help to check the folder is exist on one drive or not. below code for using for onedrive. I cannot create if condition on this.
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(Environ("UserProfile") & "\OneDrive - company name\Pictures\Camera Roll")
i = 1
For Each objFile In objFolder.Files
Range(Cells(i + 1, 1), Cells(i + 1, 1)).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
objFile.Path, _
TextToDisplay:=objFile.Name
you could set objFolder before the loop
Set objFSO = CreateObject("Scripting.FileSystemObject")
With objFSO
If .folderexists(Environ("UserProfile") & "\OneDrive - company name\Pictures\Camera Roll") Then
Set objFolder = objFSO.GetFolder(Environ("UserProfile") & "\OneDrive - company name\Pictures\Camera Roll")
Else
Set objFolder = objFSO.GetFolder(Environ("UserProfile") & "\picture\camera roll")
End If
End With
Try the next code, please. It will create hyperlinks for both cases, if both of them exist:
Sub CheckOneDriveVersusLocalToHyperlink()
Dim objFSO As Object, objFolder As Object, objFile As Object, sh As Worksheet, i As Long
Const OneDrPath As String = "\OneDrive - company name\Pictures\Camera Roll"
Const LocalPath As String = "c:\users\userprofile\picture\camera roll"
Set sh = ActiveSheet
Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FolderExists(Environ("UserProfile") & OneDrPath) Then
Set objFolder = objFSO.GetFolder(Environ("UserProfile") & OneDrPath)
i = 1
For Each objFile In objFolder.Files
ActiveSheet.Hyperlinks.Add sh.cells(i + 1, 1), Address:= _
objFile.Path, TextToDisplay:=objFile.Name
i = i + 1
Next
End If
If objFSO.FolderExists(LocalPath) Then
Set objFolder = objFSO.GetFolder(LocalPath)
i = 1
For Each objFile In objFolder.Files
ActiveSheet.Hyperlinks.Add sh.cells(i + 1, 3), Address:= _
objFile.Path, TextToDisplay:=objFile.Name
i = i + 1
Next
End If
End Sub
Please, take care to use your real paths. I do not think that the OneDrive one is correct in the way you show it. Is it a path on the intranet?
It will create hyperlinks from OneDrive in A:A column, and ones for local path in C:C column.
Of course, if you need only to create hyperlinks for the OneDrive folder (only in case it exists), you just delete the last part treating the local path. Or use Else instead of End If ... If, in case you need the hyperlink for the local path, only in case that the first one does not exist.
Related
I am creating an archiving system where I need to sort files into folders.
I create the folders automatically by mentioning the names of folder in an Excel sheet.
Now I need to copy the files with similar names in that respective folder.
E.g. A folder is created with the name "Ashley Davidson". All the files which are in one source folder and whose file name starts with Ashley Davidson should be copied to this folder.
There will be more than 500 folders and more than 10,000 files to be copied in these folders every week.
The code below creates the folders.
How can I copy the files based on similar name to these folders?
Important
The names of folders will be constant.
The start of the names of files will be similar but users add other words like date, age, sheet 1, sheet 2 etc., therefore List of Partial name concept will probably work here.
Examples of folder names
Example of file names
Code to create folders:
Sub MakeFolders()
Dim sh As Worksheet, lastR As Long, arr, i As Long, rootPath As String
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
arr = sh.Range("A2:A" & lastR).Value2
rootPath = ThisWorkbook.Path & "\"
For i = 1 To UBound(arr)
If arr(i, 1) <> "" And noIllegalChars(CStr(arr(i, 1))) Then
If Dir(rootPath & arr(i, 1), vbDirectory) = "" Then
MkDir rootPath & arr(i, 1)
End If
Else
MsgBox "Illegals characters or empty cell (" & sh.Range("A" & i + 1).Address & ")..."
End If
Next i
End Sub
Function noIllegalChars(x As String) As Boolean
Const illCh As String = "*[\/\\"":\*?]*"
If Not x Like illCh Then noIllegalChars = True
End Function
You did not answer the clarification question and I need to leave my office. The next code assumes that all files exist in a common folder and they should be moved in the folder exactly named as the string in column A:A of the active sheet. It is able to move or copy the file, according to the line you should uncomment:
Sub moveMatchedFilesInAppropriateFolders()
Dim sh As Worksheet, lastR As Long, filesPath As String, fileName As String, foldersRoot As String, folderPath As String
Dim arr, boolNotFound As Boolean, i As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
arr = sh.Range("A2:A" & lastR).Value2
foldersRoot = ThisWorkbook.Path & "\" 'use here the root folder for folders
filesPath = "your files to be processed folder" 'use here the path where the files can be found
Set fso = CreateObject("Scripting.FileSystemObject") 'to check if file exists
For i = 1 To UBound(arr)
boolNotFound = False
If Dir(foldersRoot & arr(i, 1), vbDirectory) <> "" Then
folderPath = foldersRoot & arr(i, 1) & "\"
Else
MsgBox arr(i, 1) & " folder could not be found!" & vbCrLf & _
"Please, note and correct it after copying the matching ones and run the code again!"
boolNotFound = True
End If
If Not boolNotFound Then
fileName = Dir(filesPath & arr(i, 1) & "*.*")
Do While fileName <> ""
If Not fso.FileExists(folderPath & fileName) Then 'move/copy only if it does not exist in destination fld
'uncomment the way you need (moving or copying):
'Name filesPath & fileName As folderPath & fileName 'the file is moved
'FileCopy filesPath & fileName, folderPath & fileName 'the file is copied
End If
fileName = Dir
Loop
End If
Next i
End Sub
Not tested, but it should work.
If you need something else, please better answer my last clarifications question.
Besides all that, I think it would be good to place a marker in B:B column, for not found folders, if any. In this way, the code can be adapted that at the next run to only run the ones having the marker (and delete it, if the string has been corrected and the folder has been found).
My code works from having the new Folders in the same folder as the workbook you've created said folders from (as it is in your code) and the files to be copied were in a seperate folder in the same path as your workbook; I found that easier to work with since then the only files in that folder are files to be copied, not extra folders within.
Sub copyFilesToFolder()
Dim lRow As Long
Dim wb As Workbook
Dim ws As Worksheet
Dim ccell As Range
Dim fsO As Object, oFolder As Object, oFile As Object
Dim pathFiles As String, sFolderPath As String, sSource As String, sDestination As String
Set wb = ActiveWorkbook
Set ws = wb.ActiveWorksheet
lRow = Range("A" & Rows.Count).End(xlUp).Row
pathFiles = "Q:\WHERE YOUR ORIGINAL WORKBOOK IS\Test\" 'could be gotten from wb technically
Set fsO = CreateObject("Scripting.FileSystemObject")
Set oFolder = fsO.GetFolder(pathFiles)
For Each oFile In oFolder.Files 'go through all the files
For Each ccell In Range("A2:A" & lRow).Cells 'go through all the folder-names
'Debug.Print ccell.Value2
'Debug.Print oFile.Name
If InStr(oFile.Name, ccell.Value2) > 0 Then 'if folder name is in file name
sFolderPath = wb.Path & "\" & ccell.Value2 & "\"
If Dir(sFolderPath, vbDirectory) <> "" Then 'if Folder exists
sDestination = sFolderPath & oFile.Name
If Dir(sDestination) = "" Then 'file doesn't exist yet
sSource = pathFiles & oFile.Name
'Debug.Print sSource
'Debug.Print sDestination
Call fsO.CopyFile(pathFiles & oFile.Name, sFolderPath & oFile.Name)
GoTo Skip
End If
Else
MsgBox ("Folder " & ccell.Value2 & " doesn't exist yet")
End If
End If
Next ccell
Skip:
Next oFile
End Sub
Hope this helps :)
I'm writing a Macro which main function is to rename folders in a specific server location (Main folder). All the files on this Main Folder have the 3 first characters as numbers which are in sequential order. Since I'm changing them often I wanted a Macro which was able to rename the folders from a item up (this item would be the first 3 characters of a folders name)
The the issue I have is that since the files are in a server I cannot really change the name, it seams like I just can change the name which appears to the user but not the "real"/first name.
Perhaps with a couple of images it might help:
The code we are using is the following:
Private Sub PrintFolders()
Dim objFSO As Object
Dim objFSO_2 As Object
Dim objFolder As Object
Dim objSubFolder As Object
Dim fileExcel As Object
Dim xpto As Object
Dim objSubSubFile_Excel As Object
Dim auxStringName As String, auxStringPath As String
Dim i As Integer
Application.StatusBar = ""
'Get Folder Path
auxStringPath = Range("C2").Text
If auxStringPath = "" Then
Err = 19
GoTo handleCancel
End If
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(auxStringPath)
i = 0
'Get intBegin
intBegin = CInt(Range("C3").Value)
'loops through each folder in the directory and prints their names and path
On Error GoTo handleCancel
Application.EnableCancelKey = xlErrorHandler
'MsgBox "This may take a long time: press ESC to cancel"
For Each objSubFolder In objFolder.subfolders
Application.StatusBar = objSubFolder.Path & " " & objSubFolder.Name
If CInt(Left(objSubFolder.Name, 3)) >= intBegin Then
If intBegin < 10 Then
auxStringName = "00" & CStr(intBegin + i) & Mid(objSubFolder.Name, 4)
ElseIf intBegin < 100 Then
auxStringName = "0" & CStr(intBegin + i) & Mid(objSubFolder.Name, 4)
Else
auxStringName = CStr(intBegin + i) & Mid(objSubFolder.Name, 4)
End If
For Each fileExcel In objSubFolder.Files
If Right(fileExcel.Name, 4) = "xlsx" Or Right(fileExcel.Name, 4) = "xlsm" Then
Name auxStringPath & "\" & objSubFolder.Name & "\" & fileExcel.Name As auxStringPath & "\" & objSubFolder.Name & "\" & Left(auxStringName, 3) & Mid(fileExcel.Name, 4)
End If
Next fileExcel
Name auxStringPath & "\" & objSubFolder.Name As auxStringPath & "\" & auxStringName
i = i + 1
End If
Next objSubFolder
handleCancel:
If Err = 18 Then
MsgBox "You cancelled"
ElseIf Err = 19 Then
MsgBox "Missing Path"
End If
Set objFSO = Nothing
Set objFolder = Nothing
End Sub
Does anyone can help on this?
Does anzone has alreadz had a similar issue?
I have a folder with a lot of subfolders, they're named based on a pattern with an iterating number in it for 98% of the folders.
I would like to find the highest number(name of sub folder,maxNumber =??) in it, how to do this?
numOfRows = maxFolder- 32020
'loops through each file in the directory and prints their names and path
'For Each objSubFolder In objFolder.subfolders to slow....
for pnr = 32020 to maxFolder
DoEvents
Call ProgressBar.setMessage("Updating for .." & pnr, ((i + 1) / (numOfRows + 1)) * 100)
You want to find subfolders with the highest number of what, exactly? This is probably a good place to get started.
http://www.learnexcelmacro.com/wp/download/
Here is the script.
Sub GetFilesInFolder(SourceFolderName As String, Subfolders As Boolean)
'--- For Example:Folder Name= "D:\Folder Name\" and Flag as Yes or No
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.folder, SubFolder As Scripting.folder
Dim FileItem As Scripting.File
'Dim r As Long
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
'--- This is for displaying, whereever you want can be configured
r = 14
For Each FileItem In SourceFolder.Files
Cells(r, 2).Formula = r - 13
Cells(r, 3).Formula = FileItem.Name
Cells(r, 4).Formula = FileItem.Path
Cells(r, 5).Formula = FileItem.Size
Cells(r, 6).Formula = FileItem.Type
Cells(r, 7).Formula = FileItem.DateLastModified
Cells(r, 8).Formula = "=HYPERLINK(""" & FileItem.Path & """,""" & "Click Here to Open" & """)"
r = r + 1 ' next row number
Next FileItem
'--- This is the Function to go each and Every Folder and get the Files. This is a Nested-Function Calling.
If Subfolders = True Then
For Each SubFolder In SourceFolder.Subfolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
Finally, form the link above, you can download a sample file, named 'File Manager'; click 'Download Now' to get the file. That should do what you want.
I have created a code to give me path and there names for all the files in a folder to excel.
But my problem is its giving me file names of all the files in that folder. I just want to search and retrieve names of only pdf files to excel.
Here is what I have:
Sub Example1()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(Range("H1").Value)
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file path
Cells(i + 3, 2) = objFile.Path
i = i + 1
Next objFile
End Sub
As per the comments. You need to test if the last three characters are 'pdf'
So in your for loop add the if statement
For Each objFile In objFolder.Files
if right(objFile.Path,3) = "pdf" then
'print file path
Cells(i + 3, 2) = objFile.Path
i = i + 1
end if
Next objFile
This should work:
Sub Find_PDF()
Dim FileToCheck As String, FilePath As String, FileWildCard As String
FilePath = "c:\YOUR FILE PATH\"
FileWildCard = "*.pdf"
FileToCheck = Dir(FilePath & FileWildCard)
Do While FileToCheck <> ""
i = i + 1
Sheets("Sheet1").Range("A" & i).Value = FileToCheck
FileToCheck = Dir()
Loop
End Sub
This is not a free coding service but i would answer this anyway:
For Each objFile In objFolder.Files
if right(objFile.Path,3) = "pdf" then
'print file path
Cells(i + 3, 2) = objFile.Path
i = i + 1
end if
msgbox ("Answer are here dont troll on someone")
Next objFile
How to get the size of the posters by using vba excel. I am using windows 7 operating system.
Images are present on some other path. Ex. d:\posterbank\a.jpeg,b.jpeg and excel file contains only names like a.jpeg, b.jpeg.
I want to check if these posters are there if yes need to check size of these.
A = LTrim(RTrim(Sheets(sheetno).Range("m" & rowno).Value))
postername = Left(A, Len(A) - 4) & ".bmp"
If filesys.fileExists(Poster_SPath & "\" & postername) Then
Else: Call appendtofile(vbrLf & "Not found " & Eng_Title & " " & postername, Logfile_Path & "\" & "log.txt")
End If
This should get you started :) I have taken the example of 1 picture, I am sure you can amend it to loop the relevant cells and pick up the values :)
TRIED AND TESTED
'~~> Path where images reside
Const FilePath As String = "C:\Documents and Settings\All Users\Documents\My Pictures\Sample Pictures\"
Sub Sample()
Dim Filename As String
'~~> Replace this with the relevant cell value
Filename = "Sunset.JPG"
'~> Check if file exists
If FileFolderExists(FilePath & Filename) = True Then
'~~> In sheet 2 insert the image temporarily
With Sheets("Sheet2")
.Pictures.Insert(FilePath & Filename).Select
'~~> Get dimensions
MsgBox "Picture demensions: " & Selection.Width & " x " & Selection.Height
'~~> Delete the picture
Selection.Delete
End With
End If
End Sub
Public Function FileFolderExists(strFullPath As String) As Boolean
On Error GoTo EarlyExit
If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True
EarlyExit:
On Error GoTo 0
End Function
This Worked for Me
Option Explicit
Type FileAttributes
Name As String
Dimension As String
End Type
Public Function GetFileAttributes(strFilePath As String) As FileAttributes
' Shell32 objects
Dim objShell As Shell32.Shell
Dim objFolder As Shell32.Folder
Dim objFolderItem As Shell32.FolderItem
' Other objects
Dim strPath As String
Dim strFileName As String
Dim i As Integer
' If the file does not exist then quit out
If Dir(strFilePath) = "" Then Exit Function
' Parse the file name out from the folder path
strFileName = strFilePath
i = 1
Do Until i = 0
i = InStr(1, strFileName, "\", vbBinaryCompare)
strFileName = Mid(strFileName, i + 1)
Loop
strPath = Left(strFilePath, Len(strFilePath) - Len(strFileName) - 1)
' Set up the shell32 Shell object
Set objShell = New Shell
' Set the shell32 folder object
Set objFolder = objShell.Namespace(strPath)
' If we can find the folder then ...
If (Not objFolder Is Nothing) Then
' Set the shell32 file object
Set objFolderItem = objFolder.ParseName(strFileName)
' If we can find the file then get the file attributes
If (Not objFolderItem Is Nothing) Then
GetFileAttributes.Dimension = objFolder.GetDetailsOf(objFolderItem, 36)
End If
Set objFolderItem = Nothing
End If
Set objFolder = Nothing
Set objShell = Nothing
End Function
Not tested, but using this as reference, it looks like it should be possible to load the image like this.
set myImg = loadpicture(Poster_SPath & "\" & postername & ".bmp")
And then get the width and height like this.
myImg.height
myImg.width