[已解决]求这样的代码，见附件。

st600616

求这样的代码，见附件。

最佳答案

月排行榜 / 总排行榜

dsmch

2014-2-27 12:58

st600616 发表于 2014-2-27 12:51
你好，老师，可否不自动化，用按钮操控可以么。
比如，选取后，点按钮再运行代码运算结果。

1. Sub Macro1()
   
2. Dim w(0 To 9), rng As Range, m As Range, i%
   
3. Set rng = Application.InputBox("请用鼠标选中数据区域", Type:=8)
   
4. If Not Application.Intersect(Range("b147").CurrentRegion, rng) Is Nothing Then
   
5.     For i = 0 To 9
   
6.         w(i) = i
   
7.     Next
   
8.     Range("b147").CurrentRegion.Interior.ColorIndex = xlNone
   
9.     rng.Interior.ColorIndex = 6
   
10.     For Each m In rng
    
11.         w(m.Value) = m & "@"
    
12.     Next
    
13.     x = Filter(w, "@", False)
    
14.     [an:an].ClearContents
    
15.     [an1].Resize(UBound(x) + 1, 1) = Application.Transpose(x)
    
16. End If
    
17. End Sub
    

复制代码

跳转到最佳答案楼层

sgxb123431380

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   dim arr
   dim n,i,k
    Range("B147:AJ164").Interior.ColorIndex = xlNone
    Selection.Interior.ColorIndex = 6
    Columns("AN").Clear
    arr = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9)
    For Each n In Selection
        arr(n.Text) = ""
    Next n
    k = 0
    For i = 0 To 9
        If arr(i) <> "" Then
            Range("AN" & 1 + k) = arr(i)
            k = k + 1
        End If
    Next i
End Sub
写在当前sheet页里

st600616

sgxb123431380 发表于 2014-2-27 12:36
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Range("B147:AJ164").Interior.Color ...

有错误，变量为定义

dsmch

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2. If Not Application.Intersect(Range("b147").CurrentRegion, Target) Is Nothing Then
   
3.     Dim w(0 To 9), m As Range, i%
   
4.     For i = 0 To 9
   
5.         w(i) = i
   
6.     Next
   
7.     Range("b147").CurrentRegion.Interior.ColorIndex = xlNone
   
8.     Target.Interior.ColorIndex = 6
   
9.     For Each m In Target
   
10.         w(m.Value) = m & "@"
    
11.     Next
    
12.     x = Filter(w, "@", False)
    
13.     Range("an1:an65536").ClearContents
    
14.     Range("an1").Resize(UBound(x) + 1, 1) = Application.Transpose(x)
    
15. End If
    
16. End Sub
    

复制代码

dsmch

………………

sgxb123431380

st600616 发表于 2014-2-27 12:38
有错误，变量为定义

那是你设定强制声明变量了吧，去掉就可以了，或者把变量都声明一下,在上面改好了

st600616

dsmch 发表于 2014-2-27 12:46

你好，老师，可否不自动化，用按钮操控可以么。
比如，选取后，点按钮再运行代码运算结果。

zjdh

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Arr, N, K%, I%
    Cells.Interior.ColorIndex = xlNone
    Selection.Interior.ColorIndex = 6
    Columns("AN").Clear
    Arr = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9)
    For Each N In Selection
        If N <> "" Then Arr(N.Text) = ""
    Next N
    K = 0
    For I = 0 To 9
        If Arr(I) <> "" Then
            Range("AN" & 1 + K) = Arr(I)
            K = K + 1
        End If
    Next I
End Sub

st600616

sgxb123431380 发表于 2014-2-27 12:36
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   dim arr
   dim n,i,k

可否不自动化， 用按钮操控

dsmch

st600616 发表于 2014-2-27 12:51
你好，老师，可否不自动化，用按钮操控可以么。
比如，选取后，点按钮再运行代码运算结果。

1. Sub Macro1()
   
2. Dim w(0 To 9), rng As Range, m As Range, i%
   
3. Set rng = Application.InputBox("请用鼠标选中数据区域", Type:=8)
   
4. If Not Application.Intersect(Range("b147").CurrentRegion, rng) Is Nothing Then
   
5.     For i = 0 To 9
   
6.         w(i) = i
   
7.     Next
   
8.     Range("b147").CurrentRegion.Interior.ColorIndex = xlNone
   
9.     rng.Interior.ColorIndex = 6
   
10.     For Each m In rng
    
11.         w(m.Value) = m & "@"
    
12.     Next
    
13.     x = Filter(w, "@", False)
    
14.     [an:an].ClearContents
    
15.     [an1].Resize(UBound(x) + 1, 1) = Application.Transpose(x)
    
16. End If
    
17. End Sub
    

复制代码