| 楼主 海绵宝宝 |
瞬间处理庞大数据量，真正实现多工作簿多工作表数据记录汇总 ，哇哈哈哈哈由于懒的找数据源了，所以数据源内的几个文件是同一个文件复制的，哈哈，这不要紧（当实验用），关键是看运行结果，素材来源请看编辑采录号 下面就看我的实验结果吧  实验室.rar |
| 2楼 eqzh |
VBA工程的密码给一个，学习一下 |
| 3楼 wxfd1 |
怎么使用啊 |
| 4楼 zmx |
这合并，不是汇总相加计算 |
| 5楼 zmx |
多工作簿多工作表数据相加汇总代码如何 |
| 6楼 沧海巫山 |
没什用处 |
| 7楼 chuchienhsin |
没密码，不能学习 |
| 8楼 qinhuan66 |
好好学习天天向上 |
| 9楼 luckydog |
加密的呀,不能用 |
| 10楼 peal |
下载老出错有限制吗 |
| 11楼 胖子 |
能否给个工程密码？ |
| 12楼 ccj11110708 |
Public Function GetExcelConnection(ByVal Path As String, Optional ByVal Headers As Boolean = True) As Connection Dim strConn As String Dim objConn As ADODB.Connection Set objConn = New ADODB.Connection strConn = "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & Path & ";" & _ "Extended Properties=""Excel 8.0;HDR=" & _ IIf(Headers, "Yes", "No") & """" objConn.Open strConn Set GetExcelConnection = objConn End Function Public Sub PutRecordsetInSheet(ByVal RS As Recordset, ByVal TopLeft As Range, _ Optional ByVal Headers As Boolean = True) Dim objField As ADODB.Field Dim i As Integer If Headers Then For Each objField In RS.Fields i = i + 1 TopLeft.Cells(1, i).Value = objField.Name Next objField TopLeft.Cells(2, 1).CopyFromRecordset RS Else TopLeft.Cells(1, 1).CopyFromRecordset RS End If End Sub Public Function GetTableName(objConn As Connection) Dim strWorksheetlist As String Set objrs = objConn.OpenSchema(adSchemaTables) Do While Not objrs.EOF strTable = objrs.Fields("table_name").Value If (Right(strTable, 1) = "$") Or (Right(strTable, 2) = "$'") Then strWorksheetlist = strWorksheetlist & "," & strTable End If objrs.MoveNext Loop GetTableName = Split(strWorksheetlist, ",") Set objrs = Nothing End Function Sub test() Dim cnn As ADODB.Connection Dim rst As ADODB.Recordset Dim ARR Dim STR As String Dim filename As String filename = Dir(ThisWorkbook.Path & "\数据源\*.xls") Do While filename <> "" Set cnn = GetExcelConnection(ThisWorkbook.Path & "\数据源\" & filename, True) ARR = GetTableName(cnn) STR = "" For i = 1 To UBound(ARR) STR = STR & "select * from [" & ARR(i) & "] where NOT(序號 IS NULL) union all " Next i STR = Left(STR, Len(STR) - 10) Set rst = GetRecordSet(STR, cnn) Call PutRecordsetInSheet(rst, Cells(Cells(Cells.Rows.Count, 1).End(xlUp).Row + 1, 1), False) filename = Dir() Loop Set cnn = Nothing Set rst = Nothing End Sub Public Function GetRecordSet(ByVal StrRequest As String, objConn As Connection) Dim rst As New ADODB.Recordset rst.Open StrRequest, objConn Set GetRecordSet = rst Set rst = Nothing End Function |