[已解决]请老师修改一下代码

qh8600

排序.rar (8.24 KB, 下载次数: 14)

2014-2-17 12:48 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

过江龙

2014-2-18 09:34

qh8600 发表于 2014-2-17 14:27
运行后 最后1列不能生成数据
主要是排序后，结存数不对

Private Sub CommandButton1_Click()
  Dim arr, brr, crr
  Dim i As Integer, j As Integer, n As Integer
  Application.ScreenUpdating = False
   With Sheets("记录")
     .Range(.Cells(4, 1), .Cells(.[a65536].End(xlUp).Row, 8)).Sort Range("A4"), xlAscending, Header:=xlNo
      arr = .Range(.Cells(1, 1), .Cells(.[a65536].End(xlUp).Row, 8))
    End With
    ReDim brr(1 To UBound(arr), 1 To 8)
    For i = 4 To UBound(arr)
    If arr(i, 1) <> 0 Then
            n = n + 1
            For j = 1 To 7
              brr(n, j) = arr(i, j)
            Next j
            If n = 1 Then
               brr(n, 8) = Cells(3, 8) + brr(n, 5) - brr(n, 7)
              Else
               brr(n, 8) = brr(n - 1, 8) + brr(n, 5) - brr(n, 7)
             End If
    End If
    Next i
    With Sheets("记录")
           .Rows("4:" & .[a65536].End(xlUp).Row).Delete Shift:=xlUp
           .Range("A4").Resize(UBound(brr), 8) = brr
           .Range("A1").Resize(UBound(brr), 8).Borders.LineStyle = 1
    End With
Application.ScreenUpdating = True
End Sub

跳转到最佳答案楼层

过江龙

修改代码来解决什么问题，比明白。

qh8600

过江龙 发表于 2014-2-17 13:58
修改代码来解决什么问题，比明白。

运行后 最后1列不能生成数据
主要是排序后，结存数不对

过江龙

qh8600 发表于 2014-2-17 14:27
运行后 最后1列不能生成数据
主要是排序后，结存数不对

Private Sub CommandButton1_Click()
  Dim arr, brr, crr
  Dim i As Integer, j As Integer, n As Integer
  Application.ScreenUpdating = False
   With Sheets("记录")
     .Range(.Cells(4, 1), .Cells(.[a65536].End(xlUp).Row, 8)).Sort Range("A4"), xlAscending, Header:=xlNo
      arr = .Range(.Cells(1, 1), .Cells(.[a65536].End(xlUp).Row, 8))
    End With
    ReDim brr(1 To UBound(arr), 1 To 8)
    For i = 4 To UBound(arr)
    If arr(i, 1) <> 0 Then
            n = n + 1
            For j = 1 To 7
              brr(n, j) = arr(i, j)
            Next j
            If n = 1 Then
               brr(n, 8) = Cells(3, 8) + brr(n, 5) - brr(n, 7)
              Else
               brr(n, 8) = brr(n - 1, 8) + brr(n, 5) - brr(n, 7)
             End If
    End If
    Next i
    With Sheets("记录")
           .Rows("4:" & .[a65536].End(xlUp).Row).Delete Shift:=xlUp
           .Range("A4").Resize(UBound(brr), 8) = brr
           .Range("A1").Resize(UBound(brr), 8).Borders.LineStyle = 1
    End With
Application.ScreenUpdating = True
End Sub

hetianjun888

学习了

hetianjun888

学习了