|
楼主 |
发表于 2020-1-15 09:44
|
显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
怎么说呢 我是在你代码基础上直接改的 取【膜片】的数据
Option Explicit
Sub DataList()
Application.ScreenUpdating = False
Application.Calculation = xlManual
Dim cnn As Object, SqlStr As String
Dim iRow As Long, iCol As Long, jRow As Long, jCol As Long, i As Long, j, m, n As Long
Dim d, arr, brr
With Sheet3
iRow = .Range("a65536").End(xlUp).Row
If iRow > 2 Then
.Range("a2:f" & iRow).Clear
End If
Set cnn = CreateObject("adodb.connection")
#If VBA7 And Win64 Then
cnn.Open "provider=microsoft.ACE.oledb.12.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
#Else
cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=yes;imex=1';data source=" & ThisWorkbook.FullName
#End If
SqlStr = "Select 客户料号,"""","""","""",sum(裁切总数),sum(原材不良品数) " & _
"from [膜片$a1:f65536] where 客户料号 is not null group by 客户料号"
.[a2:h65536].ClearContents
SqlStr = "select * from (" & SqlStr & ") where 客户料号 is not null order by 客户料号"
.[a2].CopyFromRecordset cnn.Execute(SqlStr)
Set cnn = Nothing
iRow = .Range("a65536").End(xlUp).Row
iCol = .Cells(1, Columns.Count).End(xlToLeft).Column
.Range("a2").Resize(iRow, iCol).Borders.LineStyle = True
Set d = CreateObject("scripting.dictionary")
jRow = Sheet2.Range("a65536").End(xlUp).Row
jCol = Sheet2.Cells(1, Columns.Count).End(xlToLeft).Column
brr = Sheet2.Range("a1").Resize(jRow, jCol)
arr = .Range("a1").Resize(iRow, iCol)
For j = 2 To UBound(brr)
d(brr(j, 1) & "") = j
Next
For i = 2 To UBound(arr)
If d.exists(arr(i, 1) & "") Then
m = d(arr(i, 1) & "")
For n = 2 To 4
arr(i, n) = brr(m, n)
Next
End If
Next
.[a1].Resize(UBound(arr), UBound(arr, 2)) = arr
MsgBox "更新成功!"
End With
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub
如下:【机种名】、【品名】、【材质】的结果均未提取成功。
客户料号 机种名 品名 材质 裁切总数(PCS)-求和 原材不良品数(pcs)-求和
133FH715212B 20239 80
140FH516111B 12650 222
140WHM16141B 15875 84
140WHM16261B 4080 0
|
|