[已解决]提取数据

excelpxfans001

提取数据，见附件

最佳答案

月排行榜 / 总排行榜

老司机带带我

2016-6-10 15:29

你老是一个问题问两边啊

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.     Dim arr(0 To 4), brr(0 To 4)
   
3.     If Target.Count > 1 Then Exit Sub
   
4.     If Target.Row < 7 Or Target.Row > 20 Then Exit Sub
   
5.     If Target.Column < 2 Or Target.Column > 18 Then Exit Sub
   
6.     For i = 0 To 4
   
7.         If Target.Value + i > 9 Then
   
8.             arr(i) = Target.Value + i - 10
   
9.         Else
   
10.             arr(i) = Target.Value + i
    
11.         End If
    
12.         If Target.Value - i - 1 < 0 Then
    
13.             brr(i) = Target.Value - i + 9
    
14.         Else
    
15.             brr(i) = Target.Value - i - 1
    
16.         End If
    
17.     Next
    
18.     Sheet1.[ar1:ar5] = Application.WorksheetFunction.Transpose(brr)
    
19.     Sheet1.[aq1:aq5] = Application.WorksheetFunction.Transpose(arr)
    
20. End Sub

复制代码

跳转到最佳答案楼层

老司机带带我

你老是一个问题问两边啊

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.     Dim arr(0 To 4), brr(0 To 4)
   
3.     If Target.Count > 1 Then Exit Sub
   
4.     If Target.Row < 7 Or Target.Row > 20 Then Exit Sub
   
5.     If Target.Column < 2 Or Target.Column > 18 Then Exit Sub
   
6.     For i = 0 To 4
   
7.         If Target.Value + i > 9 Then
   
8.             arr(i) = Target.Value + i - 10
   
9.         Else
   
10.             arr(i) = Target.Value + i
    
11.         End If
    
12.         If Target.Value - i - 1 < 0 Then
    
13.             brr(i) = Target.Value - i + 9
    
14.         Else
    
15.             brr(i) = Target.Value - i - 1
    
16.         End If
    
17.     Next
    
18.     Sheet1.[ar1:ar5] = Application.WorksheetFunction.Transpose(brr)
    
19.     Sheet1.[aq1:aq5] = Application.WorksheetFunction.Transpose(arr)
    
20. End Sub

复制代码

文刀天可

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, [b2:ad100]) Is Nothing Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    If Target.Value >= 0 And Target.Value <= 9 Then
       Call 生成(Target)
    End If
End Sub



Sub 生成(ByVal Target As Range)
     Dim arr(), i%, j%, k%, brr(1 To 10)
     arr = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9)
     For i = 1 To 10
         If arr(i - 1) = Target.Value Then
            For j = 1 To 10
               brr(j) = (i - 2 + j) Mod 10
            Next
         End If
     Next
     For k = 1 To 10
         If k <= 5 Then
            Range("aq" & k) = brr(k)
         Else
            Range("ar" & k - 5) = brr(k)
         End If
    Next
End Sub