续：删除整行后，连续的序号怎么办？

Question

之前有提问过：删除整行后，连续的序号怎么办？问题也解决了！
现在我又碰壁了，比如说：1、一个序号占用三行，例如：range(“c23:c25”).value=17,用以下代码运行到第17行就出错了；
                        2、序号不是一直连着的，在不同条件下，会重新编号
                                  例如：A。。
                                         1
                                    2
                                    3
                                   B。。
                                         1
                                    2
   代码如下：
 Sub 删除整行()
 Dim iLine&, strTest$
 Dim objSht As Worksheet
  For i = 1 To 65
    Set objSht = Sheets("表" & i)
    strTest = "1": iLine = 7
    Do
        If (Val(strTest) > 0) Then
            If (objSht.Range("G" & iLine) > 0) Then
                objSht.Range("c" & iLine).FormulaR1C1 = iLine - 6
                iLine = iLine + 1
            Else
                objSht.Rows(iLine).Delete
            End If
        Else
            Exit Do
        End If
        strTest = objSht.Range("C" & iLine).Text
    Loop
  Next
End Sub                                     谢谢！

Answer 1

序号从这里开始：range("c7")=1 
              range(“c23:c25”).value=17  range("D23")=室内摄像机 range("D24")=室外像.....
                range("c54")=46
               
              range("c55")=B  D55后面的单元格为空，没有数量
              range("c56")=1  
              range("c58")=3
        
              range("c59")=""
              range("c60")=1
              range(“c62:c64”).value=3  range("D62")=室内摄像机 range("D63")=室外像.....
              range("c71")=10
序号分成三类！好像有点乱啊！

Answer 2

你把你的“编号有点怪”的表弄一张来我看一下。只要一张表就行了。你的描述我看不明白。邮箱：[email protected]

Answer 3

又发？看来用公式来处理你的编号是不可行的了，手工填充也会‘遇到麻烦’的　^_^
你先试一下这段代码吧！
' 自动删除并重编号
Sub DelLine()
    Dim i&, iLine&, iNum&, iNullCnt&, strTest$
    Dim objSht As Worksheet
    
    For i = 1 To 65
        Set objSht = Sheets("表" & i)
        iLine = 7: iNullCnt = 0: iNum = 1
        Do
            strTest = objSht.Range("G" & iLine).Text
            If (Len(strTest) > 0) Then
                If (Val(strTest) > 0) Then
                    strTest = objSht.Range("C" & iLine).Text
                    If (Len(strTest) > 0) Then
                        If (Val(strTest) > 0) Then
                            objSht.Range("C" & iLine).FormulaR1C1 = iNum
                            iNum = iNum + 1
                        End If
                    End If
                    iLine = iLine + 1
                Else
                    objSht.Rows(iLine).Delete
                    If (Len(objSht.Range("G" & iLine).Text)) Then
                        objSht.Range("C" & iLine).FormulaR1C1 = iNum
                    End If
                End If
            Else
                strTest = objSht.Range("D" & iLine).Text
                If (Len(strTest) > 0) Then
                    iNum = 1
                    iNullCnt = iNullCnt + 1
                    If (iNullCnt >= 3) Then Exit Do
                End If
                iLine = iLine + 1
            End If
        Loop
    Next
End Sub

Answer 4

Sub del ()
 Dim i%, strTest$, iLine%, xuhao%
 Dim objSheet As Worksheet
 For i = 1 To 26
    Set objSheet = Sheets(i + 2)
    strTest = 1: iLine = 5
    Do
        If (Val(strTest) > 0) Then
            If (objSheet.Range("E" & iLine) > 0) Then
                objSheet.Range("A" & iLine).FormulaR1C1 = iLine - 4
                iLine = iLine + 1
            Else
                objSheet.Rows(iLine).Delete
            End If
        Else
            Exit Do
        End If
        strTest = objSheet.Range("A" & iLine).Value
    Loop
    iLine = iLine + 1
    strTest = objSheet.Range("A" & iLine).Value
    xuhao = 1
    Do
       If Val(strTest) > 0 Then
            If (objSheet.Range("E" & iLine) > 0) Then
                objSheet.Range("A" & iLine).FormulaR1C1 = xuhao
                iLine = iLine + 1
                xuhao = xuhao + 1
            Else
                objSheet.Rows(iLine).Delete
            End If
       Else
            Exit Do
       End If
        strTest = objSheet.Range("A" & iLine).Value
    Loop
    iLine = iLine + 1
    strTest = objSheet.Range("A" & iLine).Value
    xuhao = 1
    Do
       If Val(strTest) > 0 Then
            If (objSheet.Range("E" & iLine) > 0) Then
                objSheet.Range("A" & iLine).FormulaR1C1 = xuhao
                iLine = iLine + 1
                xuhao = xuhao + 1
            Else
                objSheet.Rows(iLine).Delete
            End If
       Else
            Exit Do
       End If
       strTest = objSheet.Range("A" & iLine).Value
    Loop
  Next
End Sub这是我写的，可以运行，但是很烦！

Answer 5

代码运行后，只有第一张表有改变，而且B 货物附件、小计这些行也都删掉了！
运行时错误'1004':
              方法‘range’作用于对象'_worksheet'时失败！
      指向该句：strTest = objSht.Range("G" & iLine).Text

Answer 6

与23楼一样的结果！运行时错误'1004':  
              方法‘range’作用于对象'_worksheet'时失败！  
      指向该句：strTest = objSht.Range("G" & iLine).Text  
              
              此时：strTest=""
              text与value有什么区别？

Answer 7

可能没区别。你不是说65张表的结构是一样的吗？
出现这个错误，也许某些地方‘有点区别’吧！把这一部分改一下：
    Else
        strTest = objSht.Range("D" & iLine).Text
'        If (Len(strTest) > 0) Then
'            iNum = 1
'            iNullCnt = iNullCnt + 1
'            If (iNullCnt >= 3) Then Exit Do
'        End If
        If (Len(strTest) > 0) Then iNum = 1
        iNullCnt = iNullCnt + 1
        If (iNullCnt >= 3) Then Exit Do
        iLine = iLine + 1
    End If

Answer 8

这是你的“26张表”用的代码：
' 自动删除并重编号
Sub DelLineB()
    Dim i&, iLine&, iNum&, iNullCnt&, strTest$
    Dim objSht As Worksheet    For i = 1 To 26
        Set objSht = Sheets("表" & i)   '这里你自己看着办
        iLine = 4: iNullCnt = 0: iNum = 1
        Do
            strTest = objSht.Range("E" & iLine).Text
            If (Len(strTest) > 0) Then
                If (Val(strTest) > 0) Then
                    objSht.Range("A" & iLine).FormulaR1C1 = iNum
                    iNum = iNum + 1
                    iLine = iLine + 1
                Else
                    objSht.Rows(iLine).Delete
                End If
            Else
                iNum = 1
                iNullCnt = iNullCnt + 1
                If (iNullCnt > 3) Then Exit Do
                iLine = iLine + 1
            End If
        Loop
    Next
End Sub明天上午可能不在线，有问题下午再说。