|
- Sub tt()
- ts = Cells(2, 24) '条数
- If Val(ts) = 0 Then Exit Sub
- xx = UCase(Cells(2, 22)) '箱型
- zt = UCase(Cells(2, 23)) '状态
- arr = [a1].CurrentRegion
- Set d = CreateObject("scripting.dictionary")
- For i = 2 To UBound(arr)
- x = arr(i, 18) & arr(i, 19) '箱型+状态为key
- d(x) = i
- Next
-
- x = xx & zt
- With Sheet2
- r = .[a65536].End(3).Row
- If r > 1 Then '先检查结果表中是否有相应记录,如有,在取此记录对应的单号、箱号、铅封
- brr = .[a1].CurrentRegion
- For i = 2 To UBound(brr)
- y = brr(i, 18) & brr(i, 19) '箱型+状态为key
- If y = x Then p = i
- Next
- End If
- If p > 0 Then '结果表中有相应记录,在此记录后累加
- dh = brr(p, 1): xh = brr(p, 17): qf = brr(p, 20) '单号、箱号、铅封
- Else '结果表中无相应记录,在此记录后累加
- If d.exists(x) Then
- dh = arr(d(x), 1): xh = arr(d(x), 17): qf = arr(d(x), 20)
- Else
- MsgBox "无匹配记录": Exit Sub
- End If
- End If
- ReDim crr(1 To ts, 1 To UBound(arr, 2))
- For i = 1 To ts
- If i > 1 Or p > 0 Then dh = GetNew(dh): xh = GetNew(xh): qf = GetNew(qf)
- For j = 1 To UBound(arr, 2)
- If p > 0 Then crr(i, j) = brr(p, j) Else crr(i, j) = arr(d(x), j)
- Next
- crr(i, 1) = dh: crr(i, 17) = xh: crr(i, 20) = qf
- Next
- .Cells(r + 1, 1).Resize(ts, UBound(crr, 2)) = crr
- .Activate
- End With
- End Sub
- Function GetNew(xstr) '取得xstr+1(字母数字混合型)
- If xstr = "" Then GetNew = "": Exit Function
- For i = Len(xstr) To 1 Step -1
- If Not IsNumeric(Mid(xstr, i, 1)) Then p = i: Exit For
- Next
- If p = 0 Then
- GetNew = Right("0" & Val(xstr) + 1, Len(xstr))
- Else
- sz = Mid(xstr, p + 1)
- GetNew = Mid(xstr, 1, p) & Right("0" & Val(sz) + 1, Len(sz))
- End If
- End Function
复制代码 |
|