Access开发培训
网站公告
·Access专家课堂QQ群号:151711184    ·Access快速开发平台下载地址及教程    ·欢迎加入Access专家课堂微信群!    ·如何快速搜索本站文章|示例|资料    
您的位置: 首页 > 技术文章 > Access数据库-模块/函数/VBA

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

 

相关索引:上一节 下一节



Access软件网官方交流QQ群 (群号:54525238)       Access源码网店

常见问答:

技术分类:

相关资源:

专栏作家

关于我们 | 服务条款 | 在线投稿 | 友情链接 | 网站统计 | 网站帮助