感觉你有些东西还是没有完全说清楚. 先把我刚才做的传上来,你参考一下. 如果可以的话自己改一下. 附件里面是把数据的所有表放到一个工作表了.你根据需要修改一下(代码中有一句加了提示,改那个地方) .如有问题再提出来.
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编辑过] |