VBA的修改

z601520274

求哪位老师帮忙下，将下面VBA改下，我需要拆分到文件夹后不覆盖文件夹里面原来的文件的，下面这个VBA会覆盖原来的文件，麻烦哪位老师修改下




Sub 拆分为工作簿()
Dim arr As Variant
Dim d As Object
Dim brr()
Dim i, s As Integer
Dim wb As Workbook
arr = Sheet1.UsedRange
Set d = CreateObject("scripting.dictionary")
For i = 2 To UBound(arr)
d(arr(i, 1)) = ""
Next i
Set fso = CreateObject("Scripting.FileSystemObject")
Application.SheetsInNewWorkbook = 1
For Each k In d.keys
Set wb = Workbooks.Add
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
n = 0
If fso.FolderExists(ThisWorkbook.Path & "\" & k) Then
    Set f = fso.GetFolder(ThisWorkbook.Path & "\" & k)
    f.Delete
End If
On Error Resume Next
MkDir ThisWorkbook.Path & "\" & k
For i = 2 To UBound(arr)
If arr(i, 1) = k Then
n = n + 1
For s = 1 To UBound(arr, 2)
brr(n, s) = arr(i, s)
Next s
End If
Next i
wb.Worksheets(1).[a1].Resize(1, UBound(arr, 2)) = arr
wb.Worksheets(1).[a2].Resize(n, UBound(brr, 2)) = brr
wb.SaveAs Filename:=ThisWorkbook.Path & "\" & k & "\" & k & Format(Date, "yyyymmdd") & ".xlsx"
wb.Close False
Next k
End Sub

liulang0808

保存之前可以使用dir进行判断是否有相应的同名文件存在

z601520274

liulang0808 发表于 2016-11-6 21:13
保存之前可以使用dir进行判断是否有相应的同名文件存在

不是覆盖同名文件，上面那个VBA会将表格中的非同名EXCEL清空，只留此次操作的EXCEL

lsc900707

If fso.FolderExists(ThisWorkbook.Path & "\" & k) Then
     Set f = fso.GetFolder(ThisWorkbook.Path & "\" & k)
     f.Delete
End If

把这个条件判断句删掉试试！

z601520274

lsc900707 发表于 2016-11-6 21:26
If fso.FolderExists(ThisWorkbook.Path & "\" & k) Then
     Set f = fso.GetFolder(ThisWorkbook.Path  ...

可以了，谢谢，再请问老师一个问题，我想要在多个文件下将同一个文件名的表格合并，请问有什么代码吗？最好是能每次使用时跳个窗口输入要合并的表格的名称

lsc900707

z601520274 发表于 2016-11-6 22:25
可以了，谢谢，再请问老师一个问题，我想要在多个文件下将同一个文件名的表格合并，请问有什么代码吗？最 ...

肯定可以有，不过没有万能的，要根据具体的数据来编写。