Sao chép tập tin VBA dựa trên danh sách các vấn đề thư mục cụ thể

Tôi đang cố gắng sao chép một tệp có tên từ danh sách excel và sao chép chúng vào một thư mục cụ thể bằng VBA. Tôi đang sử dụng mã của rizvisa1 từ http://ccm.net/forum/affich-689536-generate-excel-workbooks-basing-on-excel-list làm mã cơ sở. Tôi đã thành công nhận được nó để sao chép tệp chính xác với tên trong col A và col B nhưng tôi cũng muốn sao chép chúng vào các thư mục riêng lẻ có tên trong col D. Cho đến nay nó sẽ lưu các tệp vào đường dẫn cố định trong mã nhưng sẽ không đặt chúng vào các thư mục chính xác (hoặc bất kỳ vấn đề nào.) Tôi vẫn còn khá mới đối với VBA và đang sử dụng Excel 2010 nếu có vấn đề. Tôi đã bao gồm mã của tôi dưới đây. Cảm ơn!

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

microsoft-excel vba

— Chance
nguồn

Nơi bạn đang đặt biến copyTo nằm ngoài vòng lặp nên nó luôn chỉ sử dụng giá trị thư mục trong D1. mang đến colD=... và copyTo... trong vòng lặp của bạn (đâu đó sau x=x+ và nó sẽ làm việc tốt hơn

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

— gtwebb
nguồn