|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Sub Main()
Dim strPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ThisWorkbook.Path
If .Show Then strPath = .SelectedItems(1) Else Exit Sub
End With
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
' strPath = ThisWorkbook.Path & "\待处理文件\" '
Dim ar, i As Integer, iCount As Integer
Dim Fso As Object, vrtFiles(1 To 2345) As String
Dim Conn As Object, rs As Object, Dict As Object
Dim strConn As String, strSQL As String, s As String
Sheet1.Activate
Range("G:R").ClearContents
DoApp False
Range("H1:Q1") = [{"序号","物料号","名称","材料","长(mm)","宽(mm)","单位","总数","备注","箱号"}]
Set Dict = CreateObject("Scripting.Dictionary")
Set Conn = CreateObject("ADODB.Connection")
Set Fso = CreateObject("Scripting.FileSystemObject")
GetFiles strPath, Fso, vrtFiles, iCount, ThisWorkbook.Name, ".xls"
s = "Excel 12.0;HDR=no;Database="
If Application.Version < 12 Or InStr(Application.Path, "WPS") Then
s = Replace(s, "12.0", "8.0")
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source="
Else
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
End If
Conn.Open strConn & ThisWorkbook.FullName
For i = 1 To iCount
If i = 1 Then
strSQL = "SELECT * FROM [" & s & vrtFiles(i) & "].[BOM$J1:O4]"
ar = Conn.Execute(strSQL).GetRows
Range("B1") = ar(4, 0)
Range("B2") = ar(0, 0)
Range("B3") = ar(4, 3)
End If
strSQL = "SELECT F1,F2,F7,F8,F9,F4,F5,F15,IIF(ISNULL(F16),'没有箱号的行',F16) FROM [" & s & vrtFiles(i) & "].[BOM$E6:T] WHERE F1 IS NOT NULL"
Dict.Add strSQL, vbNullString
If Dict.Count = 49 Then
Cells(Rows.Count, "I").End(xlUp).Offset(1).CopyFromRecordset Conn.Execute(Join(Dict.Keys, " UNION ALL "))
Dict.RemoveAll
End If
Next
If Dict.Count Then
Cells(Rows.Count, "I").End(xlUp).Offset(1).CopyFromRecordset Conn.Execute(Join(Dict.Keys, " UNION ALL "))
End If
Conn.Close
Set Conn = Nothing
Set Dict = Nothing
Set Fso = Nothing
With Range("H1").CurrentRegion
.Sort .Item(10), xlAscending, , , , , , xlYes
ar = .Resize(.Rows.Count + 1).Value
End With
SplitData ar, 1, 10
' Range("G:R").ClearContents
DoApp
Beep
End Sub
Sub SplitData(vData, titleRow As Long, splitCol As Long)
Dim i As Long, j As Long, rowSize As Long, strName As String
rowSize = titleRow
For i = titleRow + 1 To UBound(vData) - 1
rowSize = rowSize + 1
vData(rowSize, 1) = rowSize - 1
For j = 2 To UBound(vData, 2)
vData(rowSize, j) = vData(i, j)
Next
If vData(i, splitCol) <> vData(i + 1, splitCol) Then
If Val(vData(i, splitCol)) Then strName = CStr(Val(vData(i, splitCol))) Else strName = vData(i, splitCol)
With Worksheets(strName)
.UsedRange.Offset(3).ClearContents
With .Range("A3").Resize(rowSize, j - 2)
.Columns(2).NumberFormatLocal = "@"
.Value = vData
End With
End With
rowSize = titleRow
End If
Next
End Sub
Function GetFiles(strPath As String, objFso As Object, vrtFiles() As String, iCount As Integer, strExclude As String, Optional strFilter As String = ".xls")
Dim objSubFolder As Object, objFilterFile As Object
For Each objFilterFile In objFso.GetFolder(strPath).Files
If InStr(LCase(objFilterFile.Name), strFilter) Then
If InStr(objFilterFile.Name, strExclude) = 0 Then
iCount = iCount + 1
vrtFiles(iCount) = objFilterFile.Path
End If
End If
Next
For Each objSubFolder In objFso.GetFolder(strPath).SubFolders
GetFiles objSubFolder.Path, objFso, vrtFiles, iCount, strExclude, strFilter
Next
End Function
Function DoApp(Optional b As Boolean = True)
With Application
.ScreenUpdating = b
.DisplayAlerts = b
.Calculation = -b * 30 - 4135
End With
End Function |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2022-12-16 16:50
楼主
