Excel精英培训网

 找回密码
 注册

QQ登录

只需一步,快速开始

工作中常用的Excel函数公式,全印在一张超大鼠标垫上
查看: 220|回复: 3

VBA增加排序功能

[复制链接]
发表于 2021-2-25 16:33 | 显示全部楼层 |阅读模式


各位好,以下VBA 自动汇总代码,请帮忙增加一个按 brr(1, 1) = "客户",按客户列升序排序,谢谢!

Sub a()
Dim dic As Object, reg As Object, arr, brr, i&, k, ma
Set dic = CreateObject("scripting.dictionary")
Set reg = CreateObject("vbscript.regexp")
arr = Sheet1.Range("d1").CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 3)
Sheet2.Range("d:f").ClearContents
For i = 2 To UBound(arr)
  dic(arr(i, 12)) = i
Next
k = dic.keys
brr(1, 1) = "客户": brr(1, 2) = "编码": brr(1, 3) = "规格"
For i = 0 To dic.Count - 1
  brr(i + 2, 2) = k(i): brr(i + 2, 1) = arr(dic(k(i)), 10)
  With reg
    .Global = 1
    .Pattern = ".+V"
    Set ma = .Execute(arr(dic(k(i)), 15))
  End With
  If ma.Count > 0 Then
    brr(i + 2, 3) = ma(0)
  Else
    brr(i + 2, 3) = arr(dic(k(i)), 15)
  End If
Next
Sheet2.Range("d3").Resize(UBound(brr), 3) = brr
End Sub

发表于 2021-2-26 15:48 | 显示全部楼层
藍色為新增部份:

Sub a()
Dim dic As Object, reg As Object, arr, brr, i&, k, ma
Set dic = CreateObject("scripting.dictionary")
Set reg = CreateObject("vbscript.regexp")
arr = Sheet1.Range("d1").CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 3)
Sheet2.Range("d:f").ClearContents

Set List = CreateObject("System.Collections.ArrayList")

For i = 2 To UBound(arr)
  dic(arr(i, 12)) = i
  List.Add(arr(i,10) & vbTab & arr(i, 12))
Next

List.Sort


Set dic2 = CreateObject("scripting.dictionary")
For Each Key In List
   s = Split(Key, vbTab)
   dic2(s(1)) = ""
Next


k = dic2.keys

brr(1, 1) = "客户": brr(1, 2) = "编码": brr(1, 3) = "规格"
For i = 0 To dic.Count - 1
  brr(i + 2, 2) = k(i): brr(i + 2, 1) = arr(dic(k(i)), 10)
  With reg
    .Global = 1
    .Pattern = ".+V"
    Set ma = .Execute(arr(dic(k(i)), 15))
  End With
  If ma.Count > 0 Then
    brr(i + 2, 3) = ma(0)
  Else
    brr(i + 2, 3) = arr(dic(k(i)), 15)
  End If
Next
Sheet2.Range("d3").Resize(UBound(brr), 3) = brr
End Sub

祝順心,南無阿彌陀佛!

回复

使用道具 举报

 楼主| 发表于 2021-2-27 13:55 | 显示全部楼层
cutecpu 发表于 2021-2-26 15:48
藍色為新增部份:

Sub a()

下午好!
以下是另外一个老师教的,如果要满足多个件条件排序怎么弄,谢谢!
目前按客户,想按客户+编码+规格,多个条件排序。

Sub a()
Dim dic As Object, reg As Object, arr, brr, i&, k, ma
Set dic = CreateObject("scripting.dictionary")
Set reg = CreateObject("vbscript.regexp")
arr = Sheet1.Range("a5").CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 3)
Sheet2.Range("d:f").ClearContents
For i = 2 To UBound(arr)
  dic(arr(i, 17)) = i
Next
k = dic.keys
brr(1, 1) = "客户": brr(1, 2) = "编码": brr(1, 3) = "规格"
For i = 0 To dic.Count - 1
  brr(i + 2, 2) = k(i): brr(i + 2, 1) = arr(dic(k(i)), 15)
  With reg
    .Global = 1
    .Pattern = ".+V"
    Set ma = .Execute(arr(dic(k(i)), 20))
  End With
  If ma.Count > 0 Then
    brr(i + 2, 3) = ma(0)
  Else
    brr(i + 2, 3) = arr(dic(k(i)), 20)
  End If
Next
Sheet2.Range("d5").Resize(UBound(brr), 3) = brr
Sheet2.Range("d5").Resize(UBound(brr), 3).Sort Sheet2.Range("D5"), 1, Header:=1
End Sub
回复

使用道具 举报

发表于 2021-2-27 15:53 | 显示全部楼层
xhuang 发表于 2021-2-27 13:55
下午好!
以下是另外一个老师教的,如果要满足多个件条件排序怎么弄,谢谢!
目前按客户,想按客户+编 ...

紅色部份,新增編碼排序條件

Sub a()
Dim dic As Object, reg As Object, arr, brr, i&, k, ma
Set dic = CreateObject("scripting.dictionary")
Set reg = CreateObject("vbscript.regexp")
arr = Sheet1.Range("d1").CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 3)
Sheet2.Range("d:f").ClearContents

Set List = CreateObject("System.Collections.ArrayList")

For i = 2 To UBound(arr)
  dic(arr(i, 12)) = i
  List.Add(arr(i,10) & arr(i, 12) & vbTab & arr(i, 12))
Next

List.Sort


Set dic2 = CreateObject("scripting.dictionary")
For Each Key In List
   s = Split(Key, vbTab)
   dic2(s(1)) = ""
Next


k = dic2.keys

brr(1, 1) = "客户": brr(1, 2) = "编码": brr(1, 3) = "规格"
For i = 0 To dic.Count - 1
  brr(i + 2, 2) = k(i): brr(i + 2, 1) = arr(dic(k(i)), 10)
  With reg
    .Global = 1
    .Pattern = ".+V"
    Set ma = .Execute(arr(dic(k(i)), 15))
  End With
  If ma.Count > 0 Then
    brr(i + 2, 3) = ma(0)
  Else
    brr(i + 2, 3) = arr(dic(k(i)), 15)
  End If
Next
Sheet2.Range("d3").Resize(UBound(brr), 3) = brr
End Sub

祝順心,南無阿彌陀佛!
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2021-4-20 06:32 , Processed in 0.140400 second(s), 5 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表