|
感觉你有些东西还是没有完全说清楚. 先把我刚才做的传上来,你参考一下. 如果可以的话自己改一下. 附件里面是把数据的所有表放到一个工作表了.你根据需要修改一下(代码中有一句加了提示,改那个地方) .如有问题再提出来.
3YqNlLcM.rar
(80.71 KB, 下载次数: 2)
Option Explicit Sub QueryData()
Dim conn As Object
Dim sql As String
Dim path As String
Dim catADOX As New ADOX.Catalog
Dim i As Integer
Dim arrShtNames() As String '存取工作表名的数组
Dim arrRows() As Long '存取每个表标题行数
Dim intSheets As Integer '工作表数量
Dim lngLastRow As Long '当前数据行数
Dim rngCopy As Range
Application.ScreenUpdating = False
path = ThisWorkbook.path
catADOX.ActiveConnection = "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & path & "\数据.xls"
intSheets = catADOX.Tables.Count
ReDim arrShtNames(intSheets)
For i = 1 To intSheets
arrShtNames(i) = Replace(catADOX.Tables(i - 1).Name, "'", "") '取表名,并去掉单引号,以利于查询语句处理
Next i
Set catADOX = Nothing
'path = "F:\Documents and Settings\stephen\桌面\"
path = ThisWorkbook.path
Set conn = CreateObject("adodb.connection")
conn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;imex=1;';data source=" & path & "\数据.xls"
lngLastRow = 1
'Sheet1.UsedRange.Clear '每次执行查询前,清除原先的数据
For i = 1 To intSheets
sql = "select * from [" & arrShtNames(i) & "e:x]"
Set rngCopy = Sheet1.Cells(lngLastRow, 1) '这句根据需要修改:如修改为不同的表名
rngCopy.CopyFromRecordset conn.Execute(sql)
lngLastRow = rngCopy.Parent.Range("a65536").End(xlUp).Row + 1
' Stop
Next i conn.Close: Set conn = Nothing
Application.ScreenUpdating = True
End Sub
[此贴子已经被作者于2007-3-2 0:41:08编辑过] | 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2007-3-1 22:02
楼主
