EXCEL(VBA)~SQL 经典写法范本汇集(三)

时　间:2012-04-09 08:58:12
作　者:欢乐小爪   ID：20149  城市：杭州
摘　要:EXCEL(VBA)~SQL 经典写法范本汇集(三)
正　文:

回答 27019170网友的问题

1.提取本文件夹内除本工作簿以外的工作簿的一个人的姓名，货号，序号等

请输入姓名	何芝全
姓名	货号	序号	流程名称	单价	数量	金额	组别
何芝全	852152	21	上鞋舌		50	0	A组
何芝全	852361	12	车大面假线（2）		180	0	A组
何芝全	852361	21	压扣	0.01	755	7.55	A组
何芝全	852361	32	车网脚及修建	0.02	740	14.8	A组
何芝全	852152	21	上鞋舌		50	0	B组
何芝全	852361	12	车大面假线（2）		180	0	B组
何芝全	852361	21	压扣	0.01	755	7.55	B组
何芝全	852361	32	车网脚及修建	0.02	740	14.8	B组
何芝全	852152	21	上鞋舌		50	0	C组
何芝全	852361	12	车大面假线（2）		180	0	C组

代码如下：

Sub 提取工资()
Dim adoConn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim FilePath As String
Dim sql As String
Dim FileName As String
Dim MaxRow As Long
On Error GoTo 10000
Sheets("按扭界面").Select
MaxRow = Range("a65536").End(xlUp).Row
Range("a6:h" & MaxRow + 1).ClearContents
FilePath = ThisWorkbook.Path
FileName = Dir(FilePath & "\*.xls")
Do While FileName <> "" And FileName <> ThisWorkbook.Name
Set adoConn = New ADODB.Connection
adoConn.Open "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties=Excel 8.0;Data Source=" & FilePath & "\" & FileName
sql = "select 姓名,货号,序号,流程名称,单价,数量,金额,'" & Mid(FileName, 1, InStr(1, FileName, ".") - 1) & "' as 组别 " & _
" from [计算结果$] " & _
" where 姓名= '" & [b1] & "'" ' " where 姓名='" & EmployeeName & "'"
Set rs = New ADODB.Recordset
rs.Open sql, adoConn, adOpenKeyset, adLockOptimistic
Range("a" & MaxRow + 1).CopyFromRecordset rs
MaxRow = MaxRow + rs.RecordCount + 1
FileName = Dir
Loop
Set rs = Nothing
Set adoConn = Nothing

Range("a6:h" & MaxRow).HorizontalAlignment = xlCenter
Exit Sub

10000: MsgBox Error()

End Sub

2.查询本文件夹内除本工作簿以外的工作簿的姓名重名情况

先不重复---》后重复

关于不重复用sql ；重复用循环

Sub 查询重复姓名()
Dim adoConn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim FilePath As String
Dim sql As String
Dim FileName As String
Dim I&
Dim MaxRow As Long
On Error GoTo 10000
Sheets("查验重姓名").Select
MaxRow = Range("a65536").End(xlUp).Row + 1
Range("a2:b" & MaxRow).ClearContents
FilePath = ThisWorkbook.Path
FileName = Dir(FilePath & "\*.xls")
Do While FileName <> "" And FileName <> ThisWorkbook.Name
Set adoConn = New ADODB.Connection
adoConn.Open "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties=Excel 8.0;Data Source=" & FilePath & "\" & FileName

sql = "select distinct 姓名,'" & Mid(FileName, 1, InStr(1, FileName, ".") - 1) & "' as 组别 " & _
"from [计算结果$] where 姓名 is not null"

Set rs = New ADODB.Recordset
rs.Open sql, adoConn, adOpenKeyset, adLockOptimistic
Range("a" & MaxRow).CopyFromRecordset rs
MaxRow = MaxRow + rs.RecordCount
FileName = Dir
Loop
Set rs = Nothing
Set adoConn = Nothing
Range("A2:B" & MaxRow).Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False
MaxRow = Range("a65536").End(xlUp).Row
For I = MaxRow To 2 Step -1
If Cells(I, 1) = Cells(I - 1, 1) Then
Cells(I - 1, 2) = Cells(I - 1, 2) & "/" & Cells(I, 2)
Rows(I).EntireRow.Delete
ElseIf Len(Cells(I, 2)) < 5 Then
Rows(I).EntireRow.Delete
End If
Next
MsgBox "完成", 1 + 64, "i love you"
Exit Sub
10000: MsgBox Error()
End Sub
Sub 清空()
Sheets("按扭界面").Range("a6:h65536").ClearContents
End Sub

相关索引：上一节 下一节