Question

excel中一段代码单独处理一个工作簿中的数据时可以处理，改成批处理整个目录中的excel表时出错，求vba神

单表处理代码：
Sub 按列将一表分成多表()
Dim myRange As Variant
Dim myArray
Dim titleRange As Range
Dim title As String
Dim columnNum As Integer
myRange = Range("$1:$1")
myArray = WorksheetFunction.Transpose(myRange)
Set titleRange = Range("$E$1")
title = titleRange.Value
columnNum = titleRange.Column
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim i&, Myr&, Arr, num&
Dim d, k
Set d = CreateObject("Scripting.Dictionary")
Myr = Worksheets(1).UsedRange.Rows.Count
Arr = Worksheets(1).Range(Cells(2, columnNum), Cells(Myr, columnNum))
For i = 1 To UBound(Arr)
d(Arr(i, 1)) = ""
Next
k = d.keys
For i = 0 To UBound(k)
Set conn = CreateObject("adodb.connection")
conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
Sql = "select * from [" & Sheets(1).Name & "$] where " & title & " = '" & k(i) & "'"
Worksheets.Add after:=Sheets(Sheets.Count)
With ActiveSheet
.Name = k(i)
For num = 1 To UBound(myArray)
.Cells(1, num) = myArray(num, 1)
Next num
.Range("A2").CopyFromRecordset conn.Execute(Sql)
End With
Sheets(1).Select
Sheets(1).Cells.Select
Selection.Copy
Worksheets(Sheets.Count).Activate
ActiveSheet.Cells.Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Next i
conn.Close
Set conn = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
想改成批处理当前目录下所有表：
Sub 按列将一表分成多表()
Application.ScreenUpdating = False
P = ThisWorkbook.Path & "\"
f = Dir(P & "*.xlsx")
Do While f <> ""
Set w = Workbooks.Open(P & f)
'上面单表处理代码
w.Close True
f = Dir
Loop
Application.ScreenUpdating = True
MsgBox ("执行成功！")
End Sub
单表处理效果：将sheet1里的内容按A列姓名汇总到新表（张三、李四、王二）中。下面例图是按A列汇总，上面代码是按的E列汇总，我自己的数据表别名是“数据源”

改了后出现的问题：





Answer 1

你的代码逻辑思路都很混乱，应该是你东拼西凑的结果
需要实现你的效果，单纯的加这么一段代码还是不够，还需要改一些其他地方，你目前的运行错误不难修改：
conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
改成：
conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & P & f

追问

代码的确是自己百度凑起来的，你说那修改后，
Arr = Worksheets(1).Range(Cells(2, columnNum), Cells(Myr, columnNum))

这句又出错了，现在的效果是工作表已全部建好了，但是里没没有值！！！！