提问者:小点点

复制Excel单元格、评估内容并将在单元格内容上循环的文件复制为文件名


我为此添加了一个附加图像。DocType列会从"Doc类型"工作表自动复制到此工作表中。内容可以更改,填写的单元格数量也可以更改。因此,公式创建第一列,我需要vb来评估文件路径列的结果,并将"C:\test\image\test. TIF"复制到在那里创建的文件路径需要多少次。我目前拥有的下面的代码要简单得多,但我不知道该朝哪个方向发展。

    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

我还是个新手,我已经尝试了8个小时,但还是做不到。这是我简单枚举和复制的工作代码。如果它需要一个完全不同的方法,请提供你的任何想法。提前感谢。


共1个答案

匿名用户

如果我正确理解输入(屏幕非常有帮助),以下代码将完成这项工作:

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

希望这是有帮助的。