[已解决]急，急，各位老师，帮帮忙!

huangjinyui

各位老师帮我看看，究竟VBA工程差哪里不符，感谢! rPtd6l6t.rar (66.59 KB, 下载次数: 0)

2010-1-15 15:04 上传

点击文件名下载附件
急，急，各位老师，帮帮忙!
[em06][em06][em06][em06][em06][em06]

[此贴子已经被作者于2010-1-15 15:04:26编辑过]

最佳答案

月排行榜 / 总排行榜

雨狐

2010-1-15 19:34

前面已有两个空行了，所以写入单元格区域是b要加上2

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address <> "$Q$1" Then Exit Sub
        If Target.Address = "$Q$1" Then
            Dim rng As Range, add1$, arow%, arr1(), arr2(), i%, b%, brow%
                Range("a3:o99").ClearContents
                Set rng = Sheets("成绩录入").Range("a:a").Find(Target.Value)
                    If Not rng Is Nothing Then
                        add1 = rng.Address
                    Do
                        arow = rng.Row
                        n = n + 1
                        ReDim Preserve arr1(1 To 15, 1 To n)
                        For i = 1 To 15
                        arr1(i, n) = Sheets("成绩录入").Cells(arow, i)
                        Next
                        Set rng = Sheets("成绩录入").Range("a:a").FindNext(rng)
                    Loop While Not rng Is Nothing And rng.Address <> add1
                        arr2 = Application.WorksheetFunction.Transpose(arr1)
                        b = UBound(arr2)
                        Range("a3:o" & b + 2) = arr2
                    End If
        End If
        brow = Range("a65536").End(xlUp).Row
        Range("A3:O" & brow).Sort Key1:=Range("N3"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        SortMethod:=xlPinYin, DataOption1:=xlSortNormal
End Sub

 

 

3XUvnUzO.rar (66.72 KB, 下载次数: 8)

2010-1-15 19:34 上传

点击文件名下载附件
急，急，各位老师，帮帮忙!

跳转到最佳答案楼层

枯禅

先帮帮忙去了密码保护

tkgg93

工具--共享工作簿--去掉勾

huangjinyui

&nbsp;没密码保护，去掉工作簿共享也一样出问题!

雨狐

前面已有两个空行了，所以写入单元格区域是b要加上2

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address <> "$Q$1" Then Exit Sub
        If Target.Address = "$Q$1" Then
            Dim rng As Range, add1$, arow%, arr1(), arr2(), i%, b%, brow%
                Range("a3:o99").ClearContents
                Set rng = Sheets("成绩录入").Range("a:a").Find(Target.Value)
                    If Not rng Is Nothing Then
                        add1 = rng.Address
                    Do
                        arow = rng.Row
                        n = n + 1
                        ReDim Preserve arr1(1 To 15, 1 To n)
                        For i = 1 To 15
                        arr1(i, n) = Sheets("成绩录入").Cells(arow, i)
                        Next
                        Set rng = Sheets("成绩录入").Range("a:a").FindNext(rng)
                    Loop While Not rng Is Nothing And rng.Address <> add1
                        arr2 = Application.WorksheetFunction.Transpose(arr1)
                        b = UBound(arr2)
                        Range("a3:o" & b + 2) = arr2
                    End If
        End If
        brow = Range("a65536").End(xlUp).Row
        Range("A3:O" & brow).Sort Key1:=Range("N3"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        SortMethod:=xlPinYin, DataOption1:=xlSortNormal
End Sub

 

 

3XUvnUzO.rar (66.72 KB, 下载次数: 8)

2010-1-15 19:34 上传

点击文件名下载附件
急，急，各位老师，帮帮忙!