[已解决]【求助】应用vba进行条件求和计数

ccqq19850718 · 发表于 2010-1-25 20:48

3NkOpPEa.rar (2.37 KB, 下载次数: 6)

枯禅 · 发表于 2010-1-25 21:20

dtbigBMW.rar (9.9 KB, 下载次数: 109)

喜多多 · 发表于 2010-1-25 21:21

Sub tt()
Dim arr, arr1, arr2
Dim i As Long, j As Integer
Dim temp1 As Double, temp2 As Long
With Sheet1
arr = .Range(.Cells(2, 1), .Cells(65536, 3).End(xlUp))
End With
With Sheet2
arr1 = .Range(.Cells(7, 2), .Cells(65536, 2).End(xlUp))
End With
ReDim arr2(1 To UBound(arr1, 1), 1 To 2)
For j = 1 To UBound(arr1, 1)

For i = 1 To UBound(arr, 1)
    If CDate(arr(i, 3)) < CDate("2010-2-1") And arr(i, 1) = arr(j, 1) Then
       temp1 = temp1 + arr(i, 2)
       If arr(i, 2) > 500 Then temp2 = temp2 + 1
    End If

Next
arr2(j, 1) = temp1
arr2(j, 2) = temp2
temp1 = 0
temp2 = 0
Next
Sheet2.Range("B7").Offset(0, 1).Resize(UBound(arr2, 1), 2) = arr2
Erase arr, arr1, arr2
End Sub

喜多多 · 发表于 2010-1-25 21:24

Sub tt()
Rem 多多牌代码
Dim arr, arr1, arr2
Dim i As Long, j As Integer
Dim temp1 As Double, temp2 As Long
With Sheet1
arr = .Range(.Cells(2, 1), .Cells(65536, 3).End(xlUp))
End With
With Sheet2
arr1 = .Range(.Cells(7, 2), .Cells(65536, 2).End(xlUp))
End With
ReDim arr2(1 To UBound(arr1, 1), 1 To 2)
For j = 1 To UBound(arr1, 1)

For i = 1 To UBound(arr, 1)
    If CDate(arr(i, 3)) < CDate("2010-2-1") And arr(i, 1) = arr(j, 1) Then
       temp1 = temp1 + arr(i, 2)
       If arr(i, 2) > 500 Then temp2 = temp2 + 1
    End If

Next
arr2(j, 1) = temp1
arr2(j, 2) = temp2
temp1 = 0
temp2 = 0
Next
Sheet2.Range("B7").Offset(0, 1).Resize(UBound(arr2, 1), 2) = arr2
Erase arr, arr1, arr2

End Sub

leolee82 · 发表于 2010-1-25 21:54

Sub Test()
Dim Cnn As New ADODB.Connection, Rst As New ADODB.Recordset
Dim Sql As String

With Cnn
.Provider = "microsoft.jet.oledb.4.0"
.Properties("extended properties") = "excel 8.0"
.Open ThisWorkbook.FullName
End With

Sql = "select b.员工编码,a.业绩和 ,b.件数 from " & _
                     "(select 员工编码 ,sum(业绩) as 业绩和 from [数据$] where 日期<#2010-2-1# group by 员工编码) a," & _
                     "(select 员工编码 ,count(业绩) as 件数 from [数据$] where 业绩>500 and 日期<#2010-2-1# group by 员工编码) b " & _
       "where a.员工编码=b.员工编码"
Debug.Print Sql
Rst.CursorLocation = adUseClient
Rst.Open Sql, Cnn, adOpenDynamic, adLockReadOnly

Sheets("Sheet3").[a2].CopyFromRecordset Rst
Rst.Close
Cnn.Close
Set Rst = Nothing
Set Cnn = Nothing
End Sub

不知道结果对不对

f2YEEvyz.rar (10.45 KB, 下载次数: 34)

leolee82 · 发表于 2010-1-25 22:00

yqWhRWq2.rar (10.45 KB, 下载次数: 9)

ccqq19850718 · 发表于 2010-1-25 22:45

枯禅

方便给个注释吗？

枯禅 · 发表于 2010-1-25 23:25

QUOTE:

以下是引用ccqq19850718在2010-1-25 22:45:00的发言：

枯禅

方便给个注释吗？

不好意思，献丑了：

Sub test()
Dim arr
Dim i As Integer
Dim Dic As New Dictionary '前期绑定字典
Dim Did As New Dictionary
With Sheets("数据") '获取数据源数组
    arr = .Range("a2:c" & .[a65536].End(3).Row)
End With
For i = 1 To UBound(arr)
    If arr(i, 3) < #3/1/2010# Then '判断日期，这里没认真看题，应该是2月1日
        Dic(arr(i, 1)) = Dic(arr(i, 1)) + arr(i, 2) '累加业绩
        If arr(i, 2) >= 500 Then '判断是否超过500
            Did(arr(i, 1)) = Did(arr(i, 1)) + 1 '超过-计数
        Else
            Did(arr(i, 1)) = Did(arr(i, 1)) '不超过-不计数
        End If
    End If
Next
With Sheets("求值")
    .[b7:d65536].ClearContents '清除目标单元格
    .[b7].Resize(Dic.Count, 1) = Application.Transpose(Dic.Keys) '写入编码
    .[c7].Resize(Dic.Count, 1) = Application.Transpose(Dic.Items) '写入业绩
    .[d7].Resize(Dic.Count, 1) = Application.Transpose(Did.Items) '写入件数
End With
Set Dic = Nothing '释放
Set Did = Nothing
End Sub

学习一下SQL的!

ccqq19850718 · 发表于 2010-1-26 23:59

If arr(i, 3) < #3/1/2010# Then '判断日期，这里没认真看题，应该是2月1日

如何再加个约束条件，日期大于且小于

[em01]

fghi186 · 发表于 2010-1-27 08:41

提示: 作者被禁止或删除内容自动屏蔽

		自动登录	找回密码
密码			注册

fghi186 fghi186 当前离线积分 8 IP卡狗仔卡	发表于 2010-1-27 08:41 \| 显示全部楼层提示: 作者被禁止或删除内容自动屏蔽
fghi186 fghi186 当前离线积分 8 IP卡狗仔卡
	回复使用道具举报显身卡