1

要复制的单元格 - 创建文件路径

我为此添加了一个附加图像。DocType 列自动从“Doc Types”表复制到此表。内容可以根据填写的单元格数量变化和变化。所以公式创建第一列，我需要 vb 来评估文件路径列的结果，并将"C:\test\images\tester.TIF"所需的次数复制到那里创建的文件路径。我目前拥有的下面的代码要简单得多，但我不知道该往哪个方向发展。

    子 CopyEmTWO()
        暗淡为工作表
        将字符串变暗为字符串
        将 strOut 调暗为字符串
        暗淡 strFile 作为字符串
        将 strLPart 变暗为字符串
        将 strRPart 调暗为字符串
        Dim lngCnt 作为字符串
        调暗文件只要
        设置 ws = Sheets("MRT")
        lngCnt = Application.CountA(ws.Columns("A"))
        如果 lngCnt = 0 则退出 Sub
        strIn = "C:\inserver6\script\Toolbelt\MRTesting\"
        strOut = "C:\inserver6\script\Toolbelt\MRTesting\"
        strFile = "MRTesting.tif"
        '提取文件名的字符串部分并在复制循环之外键入
        strLPart = Left$(strFile, InStr(strFile, ".") - 1)
        strRPart = Right$(strFile, Len(strFile) - Len(strLPart))
        对于 lngFiles = 1 到 lngCnt
            FileCopy strIn & strFile, strOut & strLPart & "(" & lngFiles & ")" & strRPart
        下一个
    结束子

我还是一个新手，我已经花了 8 小时的时间来解决这个问题，但还是做不好。这是我用于简单枚举和复制的工作代码。如果它需要一种完全不同的方法，请提供您的任何想法。提前致谢。

4

1 回答 1

2

如果我正确理解了输入（屏幕非常有帮助），以下代码将完成这项工作：

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

假设和限制：

  1. 将警告丢失的源文件。
  2. 文件扩展名将从源中获取。
  3. 将自动创建输出文件夹（如果不存在）。
  4. 将警告已经存在的目标文件。
  5. 带有处理的字符串/文件数量的最终消息。

示例文件也共享：https ://www.dropbox.com/s/jhbkwzuxzt01kzs/CloneImage.xlsm

希望这会有所帮助。

于 2013-01-26T18:45:45.300 回答