[已解决]如何按条件提取数据？

blwhall · 发表于 2022-3-6 10:51

1.能否把按照客户编号，同一客户编号合计超过2500（因为客户姓名有重复的，客户编号每个人才是维一的，在就是同一客户可能存在多笔欠款）提取。2，也是按照客户编号提取出新增加的。请帮助，谢谢!用公式或vba都行。

最佳答案

风林火山

2022-3-7 14:34

Sub 第一要求()
Dim d, arr, brr(), crr(), k As Long, i As Long, m As Long, n As Long
Set d = CreateObject("scripting.dictionary")
arr = Sheet1.Range("a1").CurrentRegion
For k = 2 To UBound(arr) - 1
d(arr(k, 3)) = d(arr(k, 3)) + arr(k, 5)
Next k
m = d.Count - 1
For i = 0 To m
If d.items()(i) >= 2500 Then
n = n + 1
ReDim Preserve brr(1 To n)
brr(n) = d.keys()(i)
End If
Next i
d.RemoveAll
For k = 1 To UBound(brr)
d(brr(k)) = ""
Next k
n = 0
For k = 2 To UBound(arr)
If d.exists(arr(k, 3)) Then
n = n + 1
ReDim Preserve crr(1 To UBound(arr, 2), 1 To n)
For i = 1 To UBound(crr)
crr(i, n) = arr(k, i)
Next i
End If
Next k
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "大于2500数据"
Sheet1.Rows(1).Copy Range("a1")
Range("a2").Resize(UBound(crr, 2), UBound(crr)) = Application.WorksheetFunction.Transpose(crr)
Range("a:m").AutoFit
End Sub
Sub 第二要求()
Dim d, arr, brr, crr(), k As Long, i As Long, m As Long, n As Long
Set d = CreateObject("scripting.dictionary")
arr = Sheet1.Range("a1").CurrentRegion
brr = Sheet2.Range("a1").CurrentRegion
For k = 2 To UBound(arr)
d(arr(k, 3)) = ""
Next k
For i = 2 To UBound(brr)
If Not d.exists(brr(i, 3)) Then
m = m + 1
ReDim Preserve crr(1 To UBound(arr, 2), 1 To m)
For n = 1 To UBound(brr, 2)
crr(n, m) = brr(i, n)
Next n
End If
Next i
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "新增数据"
Sheet1.Rows(1).Copy Range("a1")
Range("a2").Resize(UBound(crr, 2), UBound(crr)) = Application.WorksheetFunction.Transpose(crr)
Range("a:m").AutoFit
End Sub

复制代码

风林火山 · 发表于 2022-3-7 14:34

Sub 第一要求()
Dim d, arr, brr(), crr(), k As Long, i As Long, m As Long, n As Long
Set d = CreateObject("scripting.dictionary")
arr = Sheet1.Range("a1").CurrentRegion
For k = 2 To UBound(arr) - 1
d(arr(k, 3)) = d(arr(k, 3)) + arr(k, 5)
Next k
m = d.Count - 1
For i = 0 To m
If d.items()(i) >= 2500 Then
n = n + 1
ReDim Preserve brr(1 To n)
brr(n) = d.keys()(i)
End If
Next i
d.RemoveAll
For k = 1 To UBound(brr)
d(brr(k)) = ""
Next k
n = 0
For k = 2 To UBound(arr)
If d.exists(arr(k, 3)) Then
n = n + 1
ReDim Preserve crr(1 To UBound(arr, 2), 1 To n)
For i = 1 To UBound(crr)
crr(i, n) = arr(k, i)
Next i
End If
Next k
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "大于2500数据"
Sheet1.Rows(1).Copy Range("a1")
Range("a2").Resize(UBound(crr, 2), UBound(crr)) = Application.WorksheetFunction.Transpose(crr)
Range("a:m").AutoFit
End Sub
Sub 第二要求()
Dim d, arr, brr, crr(), k As Long, i As Long, m As Long, n As Long
Set d = CreateObject("scripting.dictionary")
arr = Sheet1.Range("a1").CurrentRegion
brr = Sheet2.Range("a1").CurrentRegion
For k = 2 To UBound(arr)
d(arr(k, 3)) = ""
Next k
For i = 2 To UBound(brr)
If Not d.exists(brr(i, 3)) Then
m = m + 1
ReDim Preserve crr(1 To UBound(arr, 2), 1 To m)
For n = 1 To UBound(brr, 2)
crr(n, m) = brr(i, n)
Next n
End If
Next i
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "新增数据"
Sheet1.Rows(1).Copy Range("a1")
Range("a2").Resize(UBound(crr, 2), UBound(crr)) = Application.WorksheetFunction.Transpose(crr)
Range("a:m").AutoFit
End Sub

复制代码

blwhall · 发表于 2022-3-8 17:30

风林火山发表于 2022-3-7 14:34

非常感谢！可以按要求提取到相应数据，但是运行到最后出现如图所示。

blwhall · 发表于 2022-3-9 21:09

风林火山发表于 2022-3-7 14:34

数值是j列，不是e列，请问如何修改代码？

zt1066815277 · 发表于 2022-5-2 15:24

blwhall 发表于 2022-3-8 17:30
非常感谢！可以按要求提取到相应数据，但是运行到最后出现如图所示。

改为这个试试
Range("A:H").EntireColumn.AutoFit

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