|
|
Option Explicit
Sub test1()
Dim ar, j&, cnn As Object, rst As Object, strSQL$, strFileName$
Application.ScreenUpdating = False
Set cnn = CreateObject("ADODB.Connection")
strFileName = ThisWorkbook.FullName
Select Case Application.Version * 1
Case Is <= 11
cnn.Open "Provider=Microsoft.JET.OLEDB.4.0;Data Source=" & strFileName & ";Extended Properties='Excel 8.0;HDR=YES;IMEX=0'"
Case Is >= 12
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFileName & ";Extended Properties='Excel 12.0;HDR=YES;IMEX=0'"
End Select
strSQL = "SELECT * FROM [" & Worksheets(1).Name & "$A3:K] WHERE 刷卡设备名称<>15 and 刷卡设备名称<>16"
Set rst = cnn.Execute(strSQL)
ar = rst.GETROWS
With ThisWorkbook.Sheets(1)
With .Range("A4")
.CurrentRegion.Offset(4).Clear
ar = transArr(ar)
.Offset(1).Resize(UBound(ar), UBound(ar, 2)) = ar
End With
.Activate
End With
rst.Close: cnn.Close
Set rst = Nothing: Set cnn = Nothing
Application.ScreenUpdating = True
Beep
End Sub
Function transArr(ByVal ar) As Variant
Dim br$(), i&, j&, iStart&, iEnd&, iLeft&, iRight&
iStart = LBound(ar): iEnd = UBound(ar)
iLeft = LBound(ar, 2): iRight = UBound(ar, 2)
ReDim br(1 To iRight - iLeft + 1, 1 To iEnd - iStart + 1)
For i = 1 To UBound(br)
For j = 1 To UBound(br, 2)
br(i, j) = ar(j + iLeft - 1, i + iStart - 1)
Next j
Next i
transArr = br
End Function
|
评分
-
1
查看全部评分
-
|
楼主: 大浪飞鱼
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-12-12 17:17
