Copy Excel cells, evaluate content, and copy a file looping over the cell contents as filename

Question

Cells to copy - creates a file path

I've added an additional image to this. The DocType column is copied to this sheet automatically from the "Doc Types" sheet. The content can change and range in how many cells are filled out. So formula creates first column, I need the vb to then evaluate the results of the File Path column and copy "C:\test\images\tester.TIF" how ever many times necessary to the file path that is created there. The code below that I currently have is much more simple but I have no idea which direction to go with this.

    Sub CopyEmTWO()
        Dim ws As Worksheet
        Dim strIn As String
        Dim strOut As String
        Dim strFile As String
        Dim strLPart As String
        Dim strRPart As String
        Dim lngCnt As String
        Dim lngFiles As Long
        Set ws = Sheets("MRT")
        lngCnt = Application.CountA(ws.Columns("A"))
        If lngCnt = 0 Then Exit Sub
        strIn = "C:\inserver6\script\Toolbelt\MRTesting\"
        strOut = "C:\inserver6\script\Toolbelt\MRTesting\"
        strFile = "MRTesting.tif"
        'extract string portions of the file name and type outside the copy loop
        strLPart = Left$(strFile, InStr(strFile, ".") - 1)
        strRPart = Right$(strFile, Len(strFile) - Len(strLPart))
        For lngFiles = 1 To lngCnt
            FileCopy strIn & strFile, strOut & strLPart & "(" & lngFiles & ")" & strRPart
        Next
    End Sub

I'm still a newbie and I've taken an 8 hour stab at this one and can't get it right. Here is my working code for simply enumerating and duplicating. If it needs an entirely different approach please offer any ideas you have. Thanks in advance.

Sample file or at least screen(s) of related sheet ranges will be very much helpful. — Peter L.
@noobjet, can you show us your original data and expected output based on those sample data? It's much easier that way.. — bonCodigo

Peter L. Peter L. · Accepted Answer · 2013-01-26T18:45:45

If I understand the input correctly (screen was extremely helpful), the following piece of code will do the job:

Sub CloneImage()

Dim SampleFile As String
Dim SampleFileExt As String
Dim OutputFolder As String
Dim ResultFile As String
Dim CurrentName As String
Dim FSO As Object
Dim i As Long
Dim CopyCount As Long

SampleFile = "D:\DOCUMENTS\1.gif"
OutputFolder = "D:\DOCUMENTS\1\"
Set FSO = CreateObject("Scripting.FileSystemObject")
CopyCount = 0
Application.ScreenUpdating = False

If FSO.FileExists(SampleFile) = True Then
    SampleFileExt = "." & FSO.GetExtensionName(SampleFile)
Else
    MsgBox "Source file:" & vbNewLine & SampleFile & vbNewLine & "does not exist!"
    Exit Sub
End If

If FSO.FolderExists(OutputFolder) = False Then FSO.CreateFolder OutputFolder

For i = 2 To ThisWorkbook.ActiveSheet.Range("A1").CurrentRegion.Rows.Count

    CurrentName = ThisWorkbook.ActiveSheet.Cells(i, 1).Value
    ResultFile = OutputFolder & CurrentName & SampleFileExt
    ThisWorkbook.ActiveSheet.Cells(i, 2).Formula = ResultFile
    ThisWorkbook.ActiveSheet.Cells(i, 3).Formula = CurrentName & ": " & ResultFile
    If FSO.FileExists(ResultFile) = False Then
        FSO.CopyFile SampleFile, ResultFile
        CopyCount = CopyCount + 1
    Else
        MsgBox "Destination file:" & vbNewLine & ResultFile & vbNewLine & "already exists!"
    End If

Next i

ThisWorkbook.ActiveSheet.Range("A1").CurrentRegion.Columns.AutoFit

Application.ScreenUpdating = True
Set FSO = Nothing

MsgBox i - 2 & " string(s) processed," & vbNewLine & CopyCount & " file(s) created in:" & vbNewLine & OutputFolder

End Sub

Assumptions & Limitations:

Will warn about missing source file.
File extension will be taken from the source.
Output folder will be created automatically (if not exists).
Will warn about already existing destination files.
Final message with numbers of strings / files processed.

Sample file is also shared: https://www.dropbox.com/s/jhbkwzuxzt01kzs/CloneImage.xlsm

Hope that was helpful.

Copy Excel cells, evaluate content, and copy a file looping over the cell contents as filename

1 Answers