VBA根据判断来增加序号

q99999 · 发表于 2022-4-23 17:13

请教一下各位老师，有个问题需要请教，现在想实现一个功能：A列按顺序在原名称下按顺序增加一个编号，但是相同名称就相同序号，当判断到D列或者F列的备注含有FEN时，A列就从带有FEN的那行A列名称开始变更序号继续往下变更。处理结果跟B列一样。目的是在数据透视里面更好实现不会合并不想合并的数据。请各位老师赐教，感谢！

新建 Microsoft Excel 工作表.zip (6.99 KB, 下载次数: 9)

hasyh2008 · 发表于 2022-4-23 21:35

Sub 编号()
  Dim Dic, K%, I%, Arr(), X%
  Set Dic = CreateObject("scripting.dictionary")
  Arr = Sheet1.Range("A1").CurrentRegion
  K = 0
  For X = 2 To UBound(Arr)
If Dic.exists(Arr(X, 1)) And Dic.exists(Arr(X, 1) & "FEN") And Arr(X, 4) = "" Then
   Arr(X, 2) = Dic(Arr(X, 1))
ElseIf Dic.exists(Arr(X, 1)) And Dic.exists(Arr(X, 1) & "FEN") And Arr(X, 4) = "FEN" Then
   K = K + 1
   Dic(Arr(X, 1)) = Arr(X, 1) & "-" & K
   Dic(Arr(X, 1) & "FEN") = ""
   Arr(X, 2) = Dic(Arr(X, 1))
ElseIf Dic.exists(Arr(X, 1)) And Not Dic.exists(Arr(X, 1) & "FEN") And Arr(X, 4) = "FEN" Then
   K = K + 1
   Dic(Arr(X, 1)) = Arr(X, 1) & "-" & K
   Dic(Arr(X, 1) & "FEN") = ""
   Arr(X, 2) = Dic(Arr(X, 1))
ElseIf Dic.exists(Arr(X, 1)) And Not Dic.exists(Arr(X, 1) & "FEN") And Arr(X, 4) = "" Then
   Arr(X, 2) = Dic(Arr(X, 1))
Else
   K = K + 1
   Dic(Arr(X, 1)) = Arr(X, 1) & "-" & K
   Arr(X, 2) = Dic(Arr(X, 1))
End If
  Next X
  Sheet1.Range("A1").Resize(UBound(Arr), UBound(Arr, 2)) = Arr
  Set Dic = Nothing
End Sub

q99999 · 发表于 2022-4-23 23:42

hasyh2008 发表于 2022-4-23 21:35
Sub 编号()
Dim Dic, K%, I%, Arr(), X%
Set Dic = CreateObject("scripting.dictionary")

老师您好，大概就是这样，我尝试改了一下，没搞懂怎么改，功力还是不够。还需要您帮忙改进一下，因为表格我是大概做了几列，能否自由选择需要判断修改的列呢，比如现在的A列，我可以自由选择一列（如S列），处理到任意指定列（如输出结果到F列），另外遇到空行或者连续多个空行时继续往下执行，但是空行的地方依然不会出现数据，仅有内容的才编号进去。非常感谢！

q99999 · 发表于 2022-4-26 17:02

各位老师能否帮忙改进一下，把备注列根据相同序号的第一个备注向下修改相同的所有序号备注，我把参考都做进附件了，我原代码上怎么增加一段判断，请各位老师指教。感谢！

VBA根据判断来增加序号.zip (22.65 KB, 下载次数: 1)

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