Copy file with VBA

[Tofik]

Hi guys Hi guys, I need a VBA code which will be copy some files from Folder 1 to the Folder 2 . When I search in the internet i found some written solution but they are not exactly what I am looking for.
I want to copy not the all ( B4:B12) files it will be for example only B6, in the next search B3 and etc....
That's why I created a lot of buttons for this operation. ( See picture below )

Thanks .

TEST.xlsm
	A	B	C	D	E
1	FOLDER:	C:\Folder 1
2	FIND:	08315-0001
3
4	1	HS523217-21-PIP-ISO-08315-0001_1.pdf	5/15/2021		to Folder 2
5					to Folder 2
6					to Folder 2
7					to Folder 2
8					to Folder 2
9					to Folder 2
10					to Folder 2
11					to Folder 2
12					to Folder 2
13
14		Copy button should work in next condition :
15		B4 (file name which I found in C:\Folder 1 ) shold be copied from searched Folder 1 to the Folder 2
16		B5 (file name which I found in C:\Folder 1 ) shold be copied from searched Folder 1 to the Folder 2
17		B6 (file name which I found in C:\Folder 1) shold be copied from searched Folder 1 to the Folder 2
18		B7 (file name which I found in C:\Folder 1) shold be copied from searched Folder 1 to the Folder 2
19		B8 (file name which I found in C:\Folder 1) shold be copied from searched Folder 1 to the Folder 2
20		B9 (file name which I found in C:\Folder 1) shold be copied from searched Folder 1 to the Folder 2
21
22		C:\Folder 1
23		C:\Folder 2
24
DRAWINGS ISO

 

[ranman256]

something like this :

Public Sub Copy1FileInList()
Dim vSrcDir, vTargDir, vSrcFile, vTargFile, vVal
Dim r As Long

vSrcDir = FixDir(Range("B1").Value)

r = ActiveCell.Row
Range("B" & r).Select
vVal = ActiveCell.Value
vTargDir = FixDir(ActiveCell.Offset(0, 3).Value)
vSrcFile = vSrcDir & vVal
vTargFile = vTargDir & vVal
 
Copy1File vSrcFile, vTargDir
 
End Sub

Private Function FixDir(pvPath)
If pvPath = "" Then Exit Function
If Right(pvPath, 1) <> "\" Then pvPath = pvPath & "\"
FixDir = pvPath
End Function

Private Function Copy1File(ByVal pvSrc, ByVal pvTarg) As Boolean
Dim fso
On Error GoTo errMake
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CopyFile pvSrc, pvTarg
Copy1File = True
Set fso = Nothing
Exit Function
errMake:
'MsgBox Err.Description & vbCrLf & pvSrc, , "Copy1File(): " & Err
Set fso = Nothing
End Function

 

[Tofik]

Hi

ranman256, I have a question about the Folder 2.​

Where I should make some corrections about the Folder 2 in your code I can't find it?
Can you explain this think to me ?

About Folder 1 I understand in your code and it should be
vSrcDir = FixDir(Range("B1").Value) which = Folder 1

something like this :

Public Sub Copy1FileInList()
Dim vSrcDir, vTargDir, vSrcFile, vTargFile, vVal
Dim r As Long

vSrcDir = FixDir(Range("B1").Value)

r = ActiveCell.Row
Range("B" & r).Select
vVal = ActiveCell.Value
vTargDir = FixDir(ActiveCell.Offset(0, 3).Value)
vSrcFile = vSrcDir & vVal
vTargFile = vTargDir & vVal
 
Copy1File vSrcFile, vTargDir
 
End Sub

Private Function FixDir(pvPath)
If pvPath = "" Then Exit Function
If Right(pvPath, 1) <> "\" Then pvPath = pvPath & "\"
FixDir = pvPath
End Function

Private Function Copy1File(ByVal pvSrc, ByVal pvTarg) As Boolean
Dim fso
On Error GoTo errMake
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CopyFile pvSrc, pvTarg
Copy1File = True
Set fso = Nothing
Exit Function
errMake:
'MsgBox Err.Description & vbCrLf & pvSrc, , "Copy1File(): " & Err
Set fso = Nothing
End Function