provide path of files or folder in certain range of cells.
read those cells and copy those files/folder to a new folder.
create a zip of that folder.
Sample input:
Sub test()
Dim rngFile As Range, cel As Range
Dim desPath As String, filename As String
Set rngFile = ThisWorkbook.Sheets("Instructions").Range("A3", "A5")
desPath = "C:\test\"
For Each cel In rngFile
If Dir(cel) <> "" Then
filename = Dir(cel)
FileCopy cel, desPath & filename
End If
Next
End Sub
I am able to read and copy files but not able to copy folder. any way such it can copy files as well as folder which is mentioned in cells.
Try something like this:
Sub test()
Const DEST_PATH As String = "C:\test\" 'use const for fixed values
Dim rngFile As Range, cel As Range, p, fso As Object
Set fso = CreateObject("scripting.filesystemobject")
Set rngFile = ThisWorkbook.Sheets("Instructions").Range("A3:A5") ' : not ,
For Each cel In rngFile.Cells
cel.Font.Color = vbBlack
p = Trim(cel.Value)
If fso.FolderExists(p) Then 'is this a folder?
fso.copyfolder p, DEST_PATH
ElseIf fso.FileExists(p) Then 'is this a file?
fso.copyfile p, DEST_PATH
Else
cel.Font.Color = vbRed 'not an existing file or folder
End If
Next
End Sub
Related
Code below saved files to a static location and renamed them based on an index 'File names' starting on position A1.
Instead of them being saved to a constant location, can I make it save to a subfolder matching another value on the 'File names' sheet? This would be under B1 on the 'File names' sheet with names like, "John", "Dave", "Kathy" etc.
I appreciate any help!
Public Sub SaveTemplate()
Const strSavePath As String = "C:\My Documents\"
Const strTemplatePath As String = "C:\My Documents\template.xls"
Dim rngNames As Excel.Range
Dim rng As Excel.Range
Dim wkbTemplate As Excel.Workbook
Set rngNames = ThisWorkbook.Worksheets("File Names").Range("A1:A200").Values
Set wkbTemplate = Application.Workbooks.Open(strTemplatePath)
For Each rng In rngNames.Cells
wkbTemplate.SaveAs strSavePath & rng.Value
Next rng
wkbTemplate.Close SaveChanges:=False
End Sub
Like this:
Public Sub SaveTemplate()
Const strSavePath As String = "C:\My Documents\"
Const strTemplatePath As String = "C:\My Documents\template.xls"
Dim rngNames As Range, rng As Range
Set rngNames = ThisWorkbook.Worksheets("File Names").Range("A1:A200")
With Application.Workbooks.Open(strTemplatePath)
For Each rng In rngNames.Cells
'include folder name from Col B
.SaveAs strSavePath & rng.Offset(0, 1).Value & "\" & rng.Value
Next rng
.Close SaveChanges:=False
End With
End Sub
I'm trying to move the file from one folder to another, with a validation for that file inside my system (so far so good), however VBA presents Error 53 (file not found), however when using Debug.Print, the directory and file is correct, and I also already found the file in the folder obviously.
File name:
DRIP_SJ0187C3_AZUL_RETANGULO_FEM_RX_52_139_MODELO.jpg
Folder:
C:\OCULOS
Debug.Print result: C:\OCULOS\DRIP_SJ0187C3_AZUL_RETANGULO_FEM_RX_52_139_MODELO.jpg
VBA Code:
Sub MoveFile()
Dim FSO As Object
Dim Source, Path, File As String
Dim i As Integer
Dim rng As Range, cell As Range
Dim SourceFile As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set rng = Planilha2.Range("E2:E1048576")
Source = "C:\OCULOS\"
Path= "C:\OCULOS_SEM_ESTOQUE\"
For Each cell In rng
i = i + 1
If Planilha2.Cells(i, 5) = 0 Then
File = Planilha2.Cells(i, 1).Value
SourceFile= Source & File
Debug.Print SourceFile
FSO.MoveFile Source:=SourceFile, Destination:=Path
End If
Next cell
End Sub
The final code:
Sub MoveFile()
Dim FSO As Object
Dim Source, Path, File As String
Dim i As Long
Dim rng As Range, cell As Range
Dim SourceFile As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set rng = Planilha2.Range("E2:E1048576")
Source = "C:\OCULOS\"
Path = "C:\OCULOS_SEM_ESTOQUE\"
For Each cell In rng
i = i + 1
If Planilha2.Cells(i, 5) = 0 Then
File = Planilha2.Cells(i, 1).Value
SourceFile = Source & File
' Debug.Print Dir(SourceFile)
' Debug.Print File
FSO.MoveFile Source:=SourceFile, Destination:=Path
End If
Next cell
End Sub
I need assistance. I need to delete old files in a folder. I have a list of the files in column B and the old files are colored RGB(255,0,0). Assuming that the code would read something like:
Dim MyFolder As String
Dim MyFile As String
Dim cell As Variant
Dim source As Range
Set source = Range("c3:c8")
MyFolder = Sheets("Delete Revs").Range("K1").Value & "\"
MyFile = Dir(MyFolder & "\" & "*.*")
For Each cell In source
If cell.Interior.Color = RGB(255, 0, 0) Then
Kill MyFile
Else
End If
Next
Use the following code:
Sub DeleteFiles()
Dim MyFolder As String
Dim MyFile As String
Dim cell As Variant
Dim source As Range
MyFolder = Sheets("Delete Revs").Range("K1").Value & "\"
Set source = Range("c3:c8")
For Each cell In source
If cell.Interior.Color = vbRed Then
MyFile = MyFolder & cell.Value
If Dir(MyFile) <> "" Then
Kill MyFile
cell.Interior.Color = vbGreen 'changing the color when file deleted
End If
End If
Next
End Sub
Sub DeleteFiles()
Dim myFolder, myFile As String
Dim Cel As Variant
myFolder = Sheet1.[A1] & "\" 'Folder Path
'Looping for Visible Cells Only
For Each Cel In Sheet1.Range("C3:C8").SpecialCells(xlCellTypeVisible)
myFile = myFolder & Cel 'File Path
If Cel.Interior.Color = vbRed Then
If Len(Dir$(myFile)) > 0 Then 'If File Exits in Folder
Kill (myFile) 'Delete File
End If
End If
Next Cel
End Sub
I am trying to come up with a routine that copies only certain files out of a directory, and all sub-directories, and pastes each copied file into a destination directory. I came up with the code below, which copies all files, in a filtered list, into a destination folder, but I can't figure out how to do a recursive loop through the hierarchy. Any guidance on this would be greatly appreciated.
Sub CopyFilteredFiles()
Dim rng As Range, cell As Range
Dim sht As Worksheet
Dim LastRow As Long
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim lastChar As Integer
Dim fileName As String
DestinationFolder = "C:\Users\ryans\OneDrive\Desktop\AllYAML\"
Set sht = ActiveSheet
LastRow = sht.Cells(sht.Rows.Count, "D").End(xlUp).Row
Set rng = Range("D14:D" & LastRow)
Set FSO = CreateObject("scripting.filesystemobject")
For Each cell In rng.SpecialCells(xlCellTypeVisible)
If cell.Value <> "" Then
CopyFile = cell.Value
Debug.Print cell.Value
lastChar = InStrRev(CopyFile, "\")
fileName = Mid(CopyFile, lastChar + 1, 199)
On Error Resume Next
FSO.CopyFile Source:=CopyFile, Destination:=DestinationFolder & fileName
End If
Next cell
End Sub
I am copying files (cell list) from source to destination folder. I need to select all values from a column in excel in the form of ($A1).
My code:
Sub SourcetoDestination()
Dim rngFile As Range, cel As Range
Dim desPath As String, filename As String
Set rngFile = ThisWorkbook.Sheets("Sheet1").**Range("$A1")** 'assuming file list in ColA
desPath = "C:Destination\"
For Each cel In rngFile
If Dir(cel) <> "" Then
filename = Dir(cel)
FileCopy cel, desPath & filename 'copy to folder
End If
Next
End Sub
Problem:
My code only copy first value from the list.
if I specify range like this :
ThisWorkbook.Sheets("Sheet1").Range("A1","A3")
It works but I want to save absolute range in excel.
Could someone please guide me.Thanks in advance.
Is this what you need??:
Sub SourcetoDestination()
Dim rngFile As Range, cel As Range
Dim desPath As String, filename As String
Dim N As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
Set rngFile = ThisWorkbook.Sheets("Sheet1").Range("$A1:$A" & N) 'assuming file list in ColA
desPath = "C:Destination\"
For Each cel In rngFile
If Dir(cel) <> "" Then filename = Dir(cel)
FileCopy cel, desPath & filename 'copy to folder
End If
Next
End Sub
UNTESTED