☰

根据列表的VBA文件复制到特定目录问题

tag-icon • tag-icon microsoft-excel vba
根据列表的VBA文件复制到特定目录问题

我正在尝试使用 VBA 复制一个包含 excel 列表中名称的文件并将其复制到特定目录。我使用的是 rizvisa1 的代码http://ccm.net/forum/affich-689536-generate-excel-workbooks-based-on-excel-list作为基础代码。我已成功让它复制名称在列 A 和列 B 中的正确文件，但我还想将它们复制到名称在列 D 中的单独文件夹中。到目前为止，它会将文件保存到代码中的固定路径，但不会将它们放在正确的文件夹中（或任何文件夹中）。我对 VBA 还很陌生，如果重要的话，我正在使用 Excel 2010。我已在下面附上我的代码。谢谢！

Option Explicit

Sub copyTemplate()
   Dim lRow, x As Integer
   Dim wbName As String
   Dim fso        As Variant
   Dim dic        As Variant
   Dim colA       As String
   Dim colB       As String
   Dim colSep     As String
   Dim copyFile   As String
   Dim copyTo     As String
   Dim colD     As String

   Set dic = CreateObject("Scripting.Dictionary") 'dictionary to ensure that duplicates are not created
   Set fso = CreateObject("Scripting.FileSystemObject") 'file scripting object for fiile system manipulation

   colSep = " - " 'separater between values of col A and col B for file name
   dic.Add colSep, vbNullString ' ensuring that we never create a file when both columns are blank in between

   'get last used row in col A
   lRow = Range("A" & Rows.Count).End(xlUp).Row


   x = 1

   colD = Range("D" & x).Value 'Folder to save to

   copyFile = "C:\Users\User\Documents\New folder\BackupDocs.xls" 'template file to copy
   copyTo = "C:\Users\User\Documents\New folder\Excel Test\" & colD & "\"  'location where copied files need to be copied

   Do
    x = x + 1

    colA = Range("A" & x).Value 'col a value

    colB = Range("B" & x).Value ' col b value
    colB = Left(Range("B" & x).Value, 20) 'only retain first 20 characters



    wbName = colA & colSep & colB ' create new file name

    If (Not dic.Exists(wbName)) Then 'ensure that we have not created this file name before
      fso.copyFile copyFile, copyTo & wbName & ".xls" 'copy the file
      dic.Add wbName, vbNullString 'add to dictionary that we have created this file
   End If


Loop Until x = lRow

Set dic = Nothing ' clean up
Set fso = Nothing ' clean up

End Sub

答案1

您设置变量的位置copyTo是在循环之外，因此它始终只使用 D1 中的文件夹值。将colD=...其带入copyTo...循环内部（之后的某个地方x=x+，它应该会更好地工作。

Option Explicit

Sub copyTemplate()
   Dim lRow, x As Integer
   Dim wbName As String
   Dim fso        As Variant
   Dim dic        As Variant
   Dim colA       As String
   Dim colB       As String
   Dim colSep     As String
   Dim copyFile   As String
   Dim copyTo     As String
   Dim colD     As String

   Set dic = CreateObject("Scripting.Dictionary") 'dictionary to ensure that duplicates are not created
   Set fso = CreateObject("Scripting.FileSystemObject") 'file scripting object for fiile system manipulation

   colSep = " - " 'separater between values of col A and col B for file name
   dic.Add colSep, vbNullString ' ensuring that we never create a file when both columns are blank in between

   'get last used row in col A
   lRow = Range("A" & Rows.Count).End(xlUp).Row
   copyFile = "C:\Users\User\Documents\New folder\BackupDocs.xls" 'template file to copy

   x = 1

   Do
    x = x + 1

    colA = Range("A" & x).Value 'col a value
    'colB = Range("B" & x).Value ' This line is overwritten by the next line so delete
    colB = Left(Range("B" & x).Value, 20) 'only retain first 20 characters
    colD = Range("D" & x).Value 'Folder to save to

   copyTo = "C:\Users\User\Documents\New folder\Excel Test\" & colD & "\"  'location where copied files need to be copied

    wbName = colA & colSep & colB ' create new file name

    If (Not dic.Exists(wbName)) Then 'ensure that we have not created this file name before
      fso.copyFile copyFile, copyTo & wbName & ".xls" 'copy the file
      dic.Add wbName, vbNullString 'add to dictionary that we have created this file
   End If


Loop Until x = lRow

Set dic = Nothing ' clean up
Set fso = Nothing ' clean up

End Sub

相关内容