根据条件，自动编号

vba学习中ing · 发表于 2018-9-28 13:13

各位大神们

就是b列&c列相同的，每4个相同的编一个号，编号不重复且连续。网上找了几个自己改，不能达到要求。请高手相助。谢谢！

liulang0808 · 发表于 2018-9-28 14:14

Sub 按钮1_Click()
Set d = CreateObject("scripting.dictionary")
Set dd = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
[d1] = "新编号"
a = 1
arr = [b1].CurrentRegion
arr(2, 4) = "MTC-" & Format(a, "000")
d(arr(2, 2) & arr(2, 3)) = 1
dd(arr(2, 2) & arr(2, 3)) = 1
For j = 3 To UBound(arr)
If d.exists(arr(j, 2) & arr(j, 3)) Then
If d(arr(j, 2) & arr(j, 3)) < 4 Then
x = dd(arr(j, 2) & arr(j, 3))
arr(j, 4) = "MTC-" & Format(x, "000")
d(arr(j, 2) & arr(j, 3)) = d(arr(j, 2) & arr(j, 3)) + 1
Else
d(arr(j, 2) & arr(j, 3)) = 1
a = a + 1
arr(j, 4) = "MTC-" & Format(a, "000")
dd(arr(j, 2) & arr(j, 3)) = a
End If
Else
a = a + 1
d(arr(j, 2) & arr(j, 3)) = 1
dd(arr(j, 2) & arr(j, 3)) = a
arr(j, 4) = "MTC-" & Format(a, "000")
End If
Next j
[b1].CurrentRegion = arr
Application.ScreenUpdating = True
End Sub

复制代码

vba学习中ing · 发表于 2018-9-28 13:23

自己先顶一个

vba学习中ing · 发表于 2018-9-28 13:35

b列&c列相同，需要得到a列的效果

liulang0808 · 发表于 2018-9-28 13:37

Sub 按钮1_Click()
Application.ScreenUpdating = False
[d1] = "新编号"
a = 1
arr = [b1].CurrentRegion
arr(2, 4) = "MTC-" & Format(a, "000")
l1 = 1
For j = 3 To UBound(arr)
If arr(j, 2) & arr(j, 3) = arr(j - 1, 2) & arr(j - 1, 3) Then
If l1 < 4 Then
arr(j, 4) = "MTC-" & Format(a, "000")
l1 = l1 + 1
Else
l1 = 1
a = a + 1
arr(j, 4) = "MTC-" & Format(a, "000")
End If
Else
a = a + 1
l1 = 1
arr(j, 4) = "MTC-" & Format(a, "000")
End If
Next j
[b1].CurrentRegion = arr
Application.ScreenUpdating = True
End Sub

复制代码

liulang0808 · 发表于 2018-9-28 13:38

模拟结果是根据楼主描述来的
楼主A列的编码，没有看太明白

vba学习中ing · 发表于 2018-9-28 14:02

liulang0808 发表于 2018-9-28 13:37

第9行和第11、12、13，b列和c列一样的，但编号不一样。其实应该是一样的。

lsdongjh · 发表于 2018-9-28 14:03

Sub Test()
Dim arr As Variant, objDic As Object, objDicID As Object
Dim lngRow As Long, strKey As String
Dim lngID As Long, strID As String
Dim lngCount As Long
arr = Sheet1.Range("A2:C17")
Set objDic = CreateObject("Scripting.Dictionary")
Set objDicID = CreateObject("Scripting.Dictionary")
lngID = 0
For lngRow = LBound(arr) To UBound(arr)
strKey = arr(lngRow, 2) & "|" & arr(lngRow, 3)
objDic(strKey) = objDic(strKey) + 1
If objDicID.Exists(strKey) = False Then
lngID = lngID + 1
objDicID(strKey) = lngID
Else
If objDic(strKey) > 4 Then
lngID = lngID + 1
objDic(strKey) = 1
objDicID(strKey) = lngID
End If
End If
strID = "MTC-" & Format(objDicID(strKey), "000")
arr(lngRow, 1) = strID
Next
Sheet1.Range("A2:C17") = arr
End Sub

复制代码

一把小刀闯天下 · 发表于 2018-9-28 14:06

'你这示例是否有问题?  5-7跑哪里去了?

Option Explicit

Sub test()
  Dim arr, i, j, m, n, t1, t2
  arr = Range("a2:d" & Cells(Rows.Count, "b").End(xlUp).Row + 1)
  For i = 1 To UBound(arr, 1) - 1: arr(i, 4) = i: Next
  Call dsort(arr, 1, UBound(arr, 1) - 1, 2, True)
  For i = 1 To UBound(arr, 1) - 1
For j = i To UBound(arr, 1) - 1
   If arr(j, 2) <> arr(j + 1, 2) Then
      If j > i Then Call dsort(arr, i, j, 3, True)
      i = j: Exit For
   End If
  Next j, i
  n = 1
  For i = 1 To UBound(arr, 1) - 1
m = m + 1: arr(i, 1) = "MTC-" & Format(n, "000")
t1 = arr(i, 2) & arr(i, 3)
t2 = arr(i + 1, 2) & arr(i + 1, 3)
If m = 4 Then n = n + 1: m = 0
If t1 <> t2 Then
   If m > 0 Then n = n + 1
   m = 0
End If
  Next
  Call dsort(arr, 1, UBound(arr, 1) - 1, 4, True)
  [a2].Resize(UBound(arr, 1) - 1, UBound(arr, 2) - 1) = arr
End Sub

Function dsort(arr, first, last, key, order)
  Dim i, j, k, t
  For i = first To last - 1
For j = i + 1 To last
   If arr(i, key) < arr(j, key) Xor order Then
      For k = 1 To UBound(arr, 2)
      t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
      Next
   End If
  Next j, i
End Function

liulang0808 · 发表于 2018-9-28 14:14

原来没有注意，数据不是连续的。。。。。。

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

[求助] 根据条件，自动编号

评分

评分

评分

评分