|
- Option Explicit
- Sub test1()
-
- Dim p As String
- With Application.FileDialog(msoFileDialogFolderPicker)
- .InitialFileName = ThisWorkbook.Path
- If .Show Then p = .SelectedItems(1) Else Exit Sub
- End With
- If Right(p, 1) <> "\" Then p = p & "\"
-
- Cells.ClearContents
- DoApp False
-
- Dim Conn As Object, rs As Object, dict As Object
- Dim strFields As String, SQL As String, f As String
- Dim i As Long, pos As Long
-
- Set dict = CreateObject("Scripting.Dictionary")
- Set Conn = CreateObject("ADODB.Connection")
-
- pos = 2
- f = Dir(p & "*.xls*")
- While Len(f)
- If ThisWorkbook.FullName <> p & f Then
- If Conn.State <> 1 Then
- Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & p & f
- SQL = "SELECT * FROM [基本信息&商品信息$A22:AP22] WHERE FALSE"
- Set rs = Conn.Execute(SQL)
- For i = 0 To rs.Fields.Count - 1
- strFields = strFields & "`" & rs.Fields(i).Name & "`,"
- Range("A1").Offset(, i) = rs.Fields(i).Name
- Next
- Range("A1").Offset(, i) = "企业内部编号"
- rs.Close
- Set rs = Nothing
- End If
- SQL = "SELECT " & strFields & "'" & Split(Split(f, ".xls")(0), "数据")(1) & "' FROM [Excel 12.0;HDR=YES;Database=" & p & f & "].[基本信息&商品信息$A22:AP] WHERE LEN(商品编号)"
- dict.Add SQL, vbNullString
- If dict.Count = 49 Then
- SQL = Join(dict.Keys, " UNION ALL ")
- Range("A" & pos).CopyFromRecordset Conn.Execute(SQL)
- pos = Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row + 1
- dict.RemoveAll
- End If
- End If
- f = Dir
- Wend
-
- If dict.Count Then
- SQL = Join(dict.Keys, " UNION ALL ")
- Range("A" & pos).CopyFromRecordset Conn.Execute(SQL)
- End If
- Set dict = Nothing
-
- If Conn.State = 1 Then Conn.Close
- Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0 XML;Data Source=" & ThisWorkbook.FullName
- f = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\汇总表-" & Format(Date, "YYYYMMDD") & ".xlsx"
- If Dir(f) <> "" Then Kill f
- Conn.Execute "SELECT * INTO [" & f & "].[" & ActiveSheet.Name & "] FROM [" & ActiveSheet.Name & "$]"
-
- Conn.Close
- Set Conn = Nothing
- DoApp
- Beep
- End Sub
- Function DoApp(Optional b As Boolean = True)
- With Application
- .ScreenUpdating = b
- .DisplayAlerts = b
- .Calculation = -b * 30 - 4135
- End With
- End Function
复制代码 |
评分
-
2
查看全部评分
-
|