[已解决]如何判断数据,自动出新数据.

h284124405

那们高手帮帮忙.谢谢

如题, 就是在原有的数据里找到相应的条件, 再在另一表里调用这结果加1等于新结果.

附件更新如下:
判断.zip (10.44 KB, 下载次数: 11)

2012-8-6 11:22 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

JLxiangwei

2012-8-6 12:30

h284124405 发表于 2012-8-6 11:24
谢谢, 再帮我看看,刚刚更新了附件.谢谢

(, 下载次数: 19)

上传

点击文件名下载附件

1. 
   
2. Sub TEST()
   
3.     Dim arr, arr1, x&, y&, str$
   
4.     arr = Sheet2.Range("a1").CurrentRegion
   
5.     arr1 = Sheet1.Range("a1:c" & Cells(Rows.Count, 1).End(xlUp).Row)
   
6.     For x = 2 To UBound(arr1)
   
7.         For y = 2 To UBound(arr)
   
8.             If arr(y, 1) = arr1(x, 1) Then
   
9.                 str = str & arr(y, 2)
   
10.             End If
    
11.         Next y
    
12.         If arr1(x, 3) = 1 Then
    
13.             arr1(x, 2) = Right(str, 2) - 1
    
14.         Else
    
15.             arr1(x, 2) = (Right(str, 2) - 1) & (Right(str, 2) - arr1(x, 3))
    
16.         End If
    
17.         str = ""
    
18.     Next x
    
19.     Sheet1.Range("b2:b65536") = ""
    
20.     Sheet1.Range("b1").Resize(x - 1, 1) = Application.Index(arr1, , 2)
    
21. End Sub

复制代码

跳转到最佳答案楼层

蓝桥玄霜

在2表中有2个编号，怎么处理？

JLxiangwei

1. Sub TEST()
   
2.     Dim arr, arr1, arr2(), x&, y&
   
3.     arr = Sheet2.Range("a1").CurrentRegion
   
4.     arr1 = Sheet1.Range("a1:a" & Cells(Rows.Count, 1).End(xlUp).Row)
   
5.     ReDim arr2(0 To UBound(arr1))
   
6.     For x = 2 To UBound(arr1)
   
7.         For y = 2 To UBound(arr)
   
8.             If arr(y, 1) = arr1(x, 1) Then
   
9.                 arr2(x - 2) = arr2(x - 2) + arr(y, 2)
   
10.             End If
    
11.         Next y
    
12.     Next x
    
13.     Sheet1.Range("b2:b65536") = ""
    
14.     Sheet1.Range("b2").Resize(x, 1) = Application.Transpose(arr2)
    
15. End Sub

复制代码

JLxiangwei

判断.zip (9.45 KB, 下载次数: 24)

2012-8-6 10:29 上传

点击文件名下载附件
上传附件

蓝桥玄霜

仅供参考。

1. Sub lqxs()
   
2. Dim Arr, i&
   
3. Sheet1.Activate
   
4. Arr = [a1].CurrentRegion
   
5. For i = 2 To UBound(Arr)
   
6.     Set r1 = Sheet2.[a:a].Find(Arr(i, 1), , , 1)
   
7.     If Not r1 Is Nothing Then
   
8.         Cells(i, 2) = Sheet2.Cells(r1.Row, 2)
   
9.     End If
   
10. Next
    
11. End Sub
    

复制代码

h284124405

JLxiangwei 发表于 2012-8-6 10:29
上传附件

您这个在数据里的数据是：-1-2  是，可以出结果是：-3   如果这-3也进了数据库里

那你这样写得出来的新号是：-6  了。

JLxiangwei

h284124405 发表于 2012-8-6 10:59
您这个在数据里的数据是：-1-2  是，可以出结果是：-3   如果这-3也进了数据库里

那你这样写得出来的新 ...

我看你附件里面是-3嘛，我以为是加总呢
你想要什么样的结果，是不是想要-1，-2这样格式的

h284124405

JLxiangwei 发表于 2012-8-6 11:01
我看你附件里面是-3嘛，我以为是加总呢
你想要什么样的结果，是不是想要-1，-2这样格式的

是我想找到同一样的型号在数据里,最后一个编号.

这最后一个编号可能是这样连着的:-3-4

但我只这-4    新编号就是在这上面加1就可以

JLxiangwei

h284124405 发表于 2012-8-6 11:05
是我想找到同一样的型号在数据里,最后一个编号.

这最后一个编号可能是这样连着的:-3-4

判断.zip (10.92 KB, 下载次数: 4)

2012-8-6 11:15 上传

点击文件名下载附件

1. Sub TEST()
   
2.     Dim arr, arr1, arr2(), x&, y&, str$
   
3.     arr = Sheet2.Range("a1").CurrentRegion
   
4.     arr1 = Sheet1.Range("a1:a" & Cells(Rows.Count, 1).End(xlUp).Row)
   
5.     ReDim arr2(0 To UBound(arr1))
   
6.     For x = 2 To UBound(arr1)
   
7.         For y = 2 To UBound(arr)
   
8.             If arr(y, 1) = arr1(x, 1) Then
   
9.                str = str & "," & arr(y, 2)
   
10.                arr2(x - 2) = Mid(Right(str, 2), 1, Len(str) - 1) + 1
    
11.             End If
    
12.         Next y
    
13.         str = ""
    
14.     Next x
    
15.     Sheet1.Range("b2:b65536") = ""
    
16.     Sheet1.Range("b2").Resize(x, 1) = Application.Transpose(arr2)
    
17. End Sub

复制代码

h284124405

JLxiangwei 发表于 2012-8-6 11:14

谢谢, 再帮我看看,刚刚更新了附件.谢谢