来源:原创 点击数:3239 评论数:0 时 间: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
|