I would like to create new folder based on cell value in a sheet (Sheet3 (Cover Page) Cell B4) and with this new folder, I would like to copy multiple documents from the list (Sheet 4 Cell B5:B30) from source folder into created folder. The document list is with extension (.pdf, .docx, etc). In addition, I also would like to prevent to create folder with same name.
At this moment, I can make new folder based on cell and also can copy document in the list, but don't know how combine this two things.
Any help would be appreciated.
Thanks in advance.
'This code is for create new folder based on cell value
Sub makenewfolder()
Dim startPath As String
Dim myName As String
startPath = "H:\Users\"
myName = ThisWorkbook.Sheets("Cover Page").Range("B4").Text
If myName = vbNullString Then myName = "Testing"
Dim folderPathWithName As String
folderPathWithName = startPath & Application.PathSeparator & myName
If Dir(folderPathWithName, vbDirectory) = vbNullString Then
MkDir folderPathWithName
Else
MsgBox "Folder already exists"
Exit Sub
End If
End Sub
'This code for copy files from the document list
Sub copyfiles()
Const sourcePath As String = "C:\Users\"
Const DestPath As String = "H:\User\"
Const ListAddress As String = "B5:B30"
' Write file list to array.
Dim FileList As Variant: FileList = Sheet4.Range(ListAddress).Value
' 'Get' first file name.
Dim FName As String: FName = Dir(sourcePath)
' 'Initiate' counter.
Dim i As Long
' Loop files in SourcePath.
Do While FName <> ""
' Check if file name of current file is contained in array (FileList).
If Not IsError(Application.Match(FName, FileList, 0)) Then
' Count file.
i = i + 1
' Copy file.
FileCopy sourcePath & FName, DestPath & FName
End If
' 'Get' next file name.
FName = Dir()
Loop
' Inform user.
Select Case i
Case 0: MsgBox "No files found", vbExclamation, "No Files"
Case 1: MsgBox "Copied 1 file.", vbInformation, "Success"
Case Else: MsgBox "Copied " & i & " files.", vbInformation, "Success"
End Select
End Sub
Related
I am new to VBA and dont have that much knowledge about coding, Need kind support to open the folder via dialog box instead of giving the source folder path manually in the VBA code (Const FolderA = "Folder Path"). Code works fine with inputting manual path inside the vba code(code copied)
Public Sub MoveFiles()
Const colA = 1
Const colB = 2
Const colC = 3
Const FolderA = "H:\My Drive\Appreciation Certification\Sep 21 2022\QR Code\" ' source folder
Const srcSheet = "Source"
Dim xlS As Excel.Worksheet
Dim xlW As Excel.Workbook
Dim RN As Long ' row number
Dim fName As String
Dim fPath As String
' ready
Set xlW = ActiveWorkbook
Set xlS = xlW.Sheets(srcSheet)
RN = 2
fName = Trim(xlS.Cells(RN, colA).Text)
' run thru ColA until hit a blank
On Error Resume Next ' expect problems if no target Dir
While fName <> ""
' if it hasn't aready been moved
If Trim(xlS.Cells(RN, colC).Text) = "" Then
' got one.
' Get the path. Ensure trailing backslash
fPath = Trim(xlS.Cells(RN, colB).Text)
If Right(fPath, 1) <> "\" Then fPath = fPath & "\"
' if the target already exists, nuke it.
If Dir(fPath & fName) <> "" Then Kill fPath & fName
' move it
FileCopy FolderA & fName, fPath & fName
DoEvents
' report it
If Err.Number <> 0 Then
xlS.Cells(RN, colC).Value = "Failed: Check target Dir"
Err.Clear
Else
xlS.Cells(RN, colC).Value = Now()
End If
End If
' ready for next one
RN = RN + 1
fName = Trim(xlS.Cells(RN, colA).Text)
Wend
MsgBox "All files moved!!"
End Sub
I am new in VBA, so I have a list of document (with extension .pdf, .docx, etc) in excel column. What I would like to do is to copy all document in the list, from source folder to destination folder.
I already tried some code, it works but the code copy all the files in the folder instead of the file in list (The document list is only in B3:B10).
Any help really appreciated.
Thanks in advance.
Sub copyfile()
Dim r As Range
Dim Jajal As Range
Dim sourcePath As String, DestPath As String, FName As String
sourcePath = "C:\Users\"
DestPath = "H:\Users\"
For Each r In Range(Sheet6.Range("B3"), Sheet6.Range("B10")) 'the list document is in the sheet6 B3:B10
FName = Dir(sourcePath & r)
'Loop while files found
Do While FName <> ""
'Copy the file
FileCopy sourcePath & FName, DestPath & FName
'Search the next file
FName = Dir()
Loop
Next
End Sub
Copy Files From Range (List)
The Code
Option Explicit
' This will copy files found in a source path AND whose names
' are contained in a list (range), to a destination path,
' overwriting possible existing files.
Sub copyFiles()
Const SourcePath As String = "C:\Users\"
Const DestPath As String = "H:\Users\"
Const ListAddress As String = "B3:B10"
' Write file list to array.
Dim FileList As Variant: FileList = Sheet1.Range(ListAddress).Value
' 'Get' first file name.
Dim FName As String: FName = Dir(SourcePath)
' 'Initiate' counter.
Dim i As Long
' Loop files in SourcePath.
Do While FName <> ""
' Check if file name of current file is contained in array (FileList).
If Not IsError(Application.Match(FName, FileList, 0)) Then
' Count file.
i = i + 1
' Copy file.
FileCopy SourcePath & FName, DestPath & FName
End If
' 'Get' next file name.
FName = Dir()
Loop
' Inform user.
Select Case i
Case 0: MsgBox "No files found", vbExclamation, "No Files"
Case 1: MsgBox "Copied 1 file.", vbInformation, "Success"
Case Else: MsgBox "Copied " & i & " files.", vbInformation, "Success"
End Select
End Sub
Using Dir you loop over all the files in the directory. If you know your files, you don't need Dir. Try like the following (not tested):
Sub copyfile()
Dim r As Range
Dim Jajal As Range
Dim sourcePath As String, DestPath As String
sourcePath = "C:\Users\"
DestPath = "H:\Users\"
For Each r In Range(Sheet6.Range("B3"), Sheet6.Range("B10")) 'the list document is in the sheet6 B3:B10
'Loop while files found
If r.Value <> ""
'Copy the file
FileCopy sourcePath & r.Value, DestPath & r.Value
'Search the next file
End If
Next
End Sub
However, you could test if the file exists before you copy.
I have large number of .csv files in a folder and each file has few separation codes in them. Separation code usually will be 5 digit code eg: B82A6.
I have to copy files with a certain separation code and move them to a destination folder.
I am new to VBA. I've been searching for code to modify it to my use.
Sub Test()
Dim R As Range, r1 As Range
Dim SourcePath As String, DestPath As String, SeperationCode As String
SourcePath = "C:\Users\hr315e\Downloads\Nov_03_2019\"
DestPath = "C:\Users\hr315e\Downloads\Target\"
Set r1 = Range("A1", Range("A" & Rows.Count).End(xlUp))
For Each R In r1
SeperationCode = Dir(SourcePath & R)
Do While SeperationCode <> ""
If Application.CountIf(r1, SeperationCode) Then
FileCopy SourcePath & SeperationCode, DestPath & SeperationCode
R.Offset(0, 1).Value = SeperationCode
Else
MsgBox "Bad file: " & SeperationCode & " ==>" & SeperationCode & "<== "
End If
SeperationCode = Dir(SourcePath & "B82A6" & R.Value & "B82A6")
Loop
Next
End Sub
So, here's the code that should work for you.
As you can see, this is a version of code which I linked to you with small updates:
Sub GoThroughFilesAndCopy()
Dim BrowseFolder As String, DestinationFolder As String
Dim FileItem As Object
Dim oFolder As Object
Dim FSO As Object
Dim TempFileName As String
Dim CheckCode As String
Application.ScreenUpdating = False
' selecting the folder with files
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select the folder with files"
.Show
On Error Resume Next
Err.Clear
BrowseFolder = .SelectedItems(1)
If Err.Number <> 0 Then
MsgBox "You didn't select anything!"
Application.ScreenUpdating = True
Exit Sub
End If
On Error GoTo 0
End With
' or you may hardcode it (data from your post):
'BrowseFolder = "C:\Users\hr315e\Downloads\Nov_03_2019\"
' selecting the destination folder
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select the the destination folder"
.Show
On Error Resume Next
Err.Clear
DestinationFolder = .SelectedItems(1)
If Err.Number <> 0 Then
MsgBox "You didn't select anything!"
Application.ScreenUpdating = True
Exit Sub
End If
On Error GoTo 0
End With
' or you may hardcode it (data from your post):
'DestinationFolder = "C:\Users\hr315e\Downloads\Target\"
CheckCode = "Some string" ' this is you check code
Set FSO = CreateObject("Scripting.FileSystemObject") ' creating filesystem object
Set oFolder = FSO.getfolder(BrowseFolder) ' creating folder object
For Each FileItem In oFolder.Files 'looking through each file in selected forlder
TempFileName = ""
If UCase(FileItem.Name) Like "*.CSV*" Then 'try opening only .csv files
TempFileName = BrowseFolder & Application.PathSeparator & FileItem.Name ' getting the full name of the file (with full path)
If CheckTheFile(TempFileName, CheckCode) Then ' if the file passes the checking function
If Dir(DestinationFolder & Application.PathSeparator & FileItem.Name) = "" Then 'if the file doesn't exist in destination folder
FileCopy Source:=TempFileName, Destination:=DestinationFolder & Application.PathSeparator & FileItem.Name ' it is copied to destination
Else ' otherwise, there are to options how to deal with it further
'uncomment the part you need below:
' this will Overwrite existing file
'FSO.CopyFile Source:=TempFileName, Destination:=DestinationFolder & Application.PathSeparator & FileItem.Name
' this will get new name for file and save it as copy
'FileCopy Source:=TempFileName, Destination:=GetNewDestinationName(FileItem.Name, DestinationFolder)
End If
End If
End If
Next
Application.ScreenUpdating = True
End Sub
'////////////////////////////////////////////////////////////////////////
Function CheckTheFile(File As String, Check As String) As Boolean
Dim TestLine As String
Dim TestCondition As String
TestCondition = "*" & Check & "*" ' this is needed to look for specific text in the file, refer to Like operator fro details
CheckTheFile = False
Open File For Input As #1 ' open file to read it line by line
Do While Not EOF(1)
Line Input #1, TestLine ' put each line of the text to variable to be able to check it
If TestLine Like TestCondition Then ' if the line meets the condition
CheckTheFile = True ' then function gets True value, no need to check other lines as main condition is met
Close #1 ' don't forget to close the file, beacuse it will be still opened in background
Exit Function ' exit the loop and function
End If
Loop
Close #1 ' if condiotion is not found in file just close the file, beacuse it will be still opened in background
End Function
'////////////////////////////////////////////////////////////////////////
Function GetNewDestinationName(File As String, Destination As String) As String
Dim i As Integer: i = 1
Do Until Dir(Destination & Application.PathSeparator & "Copy (" & i & ") " & File) = "" ' if Dir(FilePath) returns "" (empty string) it means that the file does not exists, so can save new file with this name
i = i + 1 ' incrementing counter untill get a unique name
Loop
GetNewDestinationName = Destination & Application.PathSeparator & "Copy (" & i & ") " & File ' return new file name
End Function
Basically, there is one sub, which is mostly copy-paste from linked topic, and two simple functions.
I have several excel files in folder & want to rename only specific sheets of every file in the folder which contains
viz. GTLB, SALARY, GROC
Every file has a single sheet of above characters, other sheets have different names.
So, if sheet name contains above characters then change it to GROCERY.
thanks in advance
Try using this it will loop through the folder try finding files (excel files) and try looking for the strings in files that have been specified and if match found change the name.
Sub LoopThroughFiles()
'loops through all files in a folder
Dim MyObj As Object, MySource As Object, file As Variant
Dim wbk As Workbook
Dim path As String
Dim st As String
file = Dir("H:\TestCopy\testing\") 'file name
path = "H:\TestCopy\testing\" 'directory path
While (file <> "")
Set wbk = Workbooks.Open("H:\TestCopy\testing\" & file)
MsgBox "found " & file
' path = path & file 'path and filename
Call newloopTrhoughBooks
wbk.Save
wbk.Close
' Call loop_through_all_worksheets(path)
file = Dir
Wend
End Sub
Sub newloopTrhoughBooks()
Dim book As Workbook, sheet As Worksheet, text As String, text1 As String
Dim logic_string As String
Dim logic_string2 As String
Dim logic_string3 As String
logic_string = "GTLB"
logic_string2 = "SALARY"
logic_string3 = "GROC"
For Each book In Workbooks
text = text & "Workbook: " & book.Name & vbNewLine & "Worksheets: " & vbNewLine
For Each sheet In book.Worksheets
text = text & sheet.Name & vbNewLine
text1 = sheet.Name
If StrComp(logic_string, text1) = 1 Or StrComp(logic_string2, text1) = 1 Or StrComp(logic_string3, text1) = 1 Then 'compare file name
ActiveSheet.Name = text1
ActiveSheet.Name = "Change1"
End If
Next sheet
text = text & vbNewLine
Next book
MsgBox text
End Sub
Sub RenameSheets()
Dim MyFolder As String
Dim MyFile As String
Dim wbname As String
MyFolder = "E:\SSS\File Name"
MyFile = Dir(MyFolder & "\*.xls")
Application.ScreenUpdating = False
Do While MyFile <> ""
Workbooks.Open Filename:=MyFolder & "\" & MyFile
With ActiveWorkbook
wbname = "GROCERY"
'For giving filename to sheet1
'Left(.Name, InStr(.Name, ".") - 1)
For Each sheet In ActiveWorkbook.Sheets
If LCase(sheet.Name) Like "*salary*" Or LCase(sheet.Name) Like "*gtlb*" Or LCase(sheet.Name) Like "*groc*" Then
MsgBox "Found! " & sheet.Name
.Sheets(sheet.Name).Name = wbname
.Close savechanges:=True
End If
Next
'.Sheets(1).Name = wbname
'.Close savechanges:=True
End With
MyFile = Dir
Loop
Application.ScreenUpdating = True
End Sub
I had a .bat file that worked but I need this in VBA now.
I tried different approches but only managed to do this with one file at a time. So I keep starting over and over.
So:
I have a file (named 1.pdf)
I have on a excel on Sheet1 (starting with A2) a list of file names
I need VBA to create a folder named ABC (where-ever the Excel macro is located) and multiply 1.pdf as many times as needed and rename the copies with every name in the excel list.
Example:
(i have in the same folder as the macro 1.pdf) and in Excel:
A1
John.pdf
Dog.pdf
Triangle.pdf
After execution this would result in 1.pdf copied and renamed with all of those 3 names uploaded into folder :ABC
In command prompt woud look like:
if not exist "ABC\" mkdir %cd%\ABC\
copy "1.pdf" "ABC"
ren "ABC\1.pdf" "John.pdf"
copy "1.pdf" "ABC"
ren "ABC\1.pdf" "Dog.pdf"
copy "1.pdf" "ABC"
ren "ABC\1.pdf" "Triangle.pdf"
Something like this should work for you:
Sub CopyFileForEachName()
Dim rRenameList As Range
Dim rNameCell As Range
Dim sFileToCopyPath As String
Dim sFolderPath As String
Dim sFileName As String
Dim sExt As String
Dim sNewSubFolder As String
Dim sCopyErr As String
Dim sResultsMsg As String
Dim lSuccessfulCopies As Long
Dim i As Long
'These are invalid characters for the subfolder name (the double quote "" will be evaluated as a single double quote")
Const sInvalidChar As String = "\/:*?""<>|"
If Len(ActiveWorkbook.Path) > 0 Then ChDir ThisWorkbook.Path 'Start in same folder as the active workbook
sFileToCopyPath = Application.GetOpenFilename("All Files, *.*") 'Prompt user to select file to copy
If sFileToCopyPath = "False" Then Exit Sub 'Pressed cancel
sFolderPath = Left(sFileToCopyPath, InStrRev(sFileToCopyPath, Application.PathSeparator)) 'Extract the folder path
sExt = Mid(sFileToCopyPath, InStrRev(sFileToCopyPath, ".")) 'Extract the extension
'Prompt user to select the range of cells that contain the rename list
'Pressing cancel will cause an error, resume next will suppress the error and GoTo 0 will remove the On Error condition
On Error Resume Next
Set rRenameList = Application.InputBox("Select the cells that contain the rename list.", "Rename Cells Selection", Selection.Address, Type:=8)
On Error GoTo 0
If rRenameList Is Nothing Then Exit Sub 'Pressed cancel
'If the list of rename cells is ALWAYS in the same location, you can comment out the above code, and uncomment the following:
'With ActiveWorkbook.Sheets("Sheet1")
' Set rRenameList = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
' If .Row < 2 Then Exit Sub 'No data
'End With
'Prompt user to enter the destination subfolder name
'Change the Default parameter to provide a desired default subfolder name
sNewSubFolder = InputBox(Prompt:="Please enter the name of the subfolder that will store the copied and renamed files." & Chr(10) & _
"Note that if the subfolder doesn't already exist, it will be created.", _
Title:="Destination Subfolder", _
Default:="ABC")
If Len(Trim(sNewSubFolder)) = 0 Then Exit Sub 'Pressed cancel
'Verify valid subfolder name
For i = 1 To Len(sInvalidChar)
sNewSubFolder = Replace(sNewSubFolder, Mid(sInvalidChar, i, 1), " ")
Next i
sNewSubFolder = WorksheetFunction.Trim(sNewSubFolder)
If Right(sNewSubFolder, Len(Application.PathSeparator)) <> Application.PathSeparator Then sNewSubFolder = sNewSubFolder & Application.PathSeparator
'Attempt to create the subfolder
Err.Clear
On Error Resume Next
MkDir sFolderPath & sNewSubFolder
On Error GoTo 0
If Err.Number <> 0 Then
'Failed to create the subfolder
'Check if the folder already exists
If Len(Dir(sFolderPath & sNewSubFolder, vbDirectory)) = 0 Then
'Subfolder does NOT exist, the provided subfolder name must be invalid
MsgBox "Unable to create subfolder named [" & Replace(sNewSubFolder, Application.PathSeparator, "") & "] because it is an invalid name." & Chr(10) & "Exiting macro."
Exit Sub
Else
'Subfolder already exists, got error due to duplicate name
Err.Clear
End If
End If
'Loop through each cell and rename the file
For Each rNameCell In rRenameList.Cells
'Make sure to use the extension of the file being copied
If Right(rNameCell.Text, Len(sExt)) = sExt Then
sFileName = Replace(rNameCell.Text, sExt, "")
Else
sFileName = rNameCell.Text
End If
'Attempt to copy and rename the file to the destination subfolder
Err.Clear
On Error Resume Next
FileCopy sFileToCopyPath, sFolderPath & sNewSubFolder & sFileName & sExt
On Error GoTo 0
'Record successes and failures
If Err.Number <> 0 Then
sCopyErr = sCopyErr & Chr(10) & sFileName & sExt
Else
lSuccessfulCopies = lSuccessfulCopies + 1
End If
Next rNameCell
'Build results message
sResultsMsg = "Successfully copied [" & sFileToCopyPath & "] " & lSuccessfulCopies & " times into subfolder [" & sNewSubFolder & "]"
If Len(sCopyErr) > 0 Then
sResultsMsg = sResultsMsg & Chr(10) & Chr(10) & "Failed to copy with the following names: " & Chr(10) & sCopyErr
End If
'Display results message
MsgBox sResultsMsg
End Sub