[已解决]数据对号入座问题（谢谢老师）

kandhong

老师：
  我想请教的是：数据对号入座问题。
  具体思想如下：
  1、C4:K2000为"数据区"，里面有数据。
  2、L4:W2000为"生成区"。
  想要实现的效果是：
  在"生成区"内把"数据区"内数据单独显示出来。举例说明：C4:k4为01 02 05 05 06 09 10 11 12，则在
在"生成区"内按照数字的座次显示出来。
   注：由于"数据区"内数据有2000余条，使用函数公式时效率很低，反应速度慢！恳请老师给予VBA支持！！
   数字对号入座问题.rar (9.04 KB, 下载次数: 8)

2014-12-28 18:29 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

qh8600

2014-12-28 20:52

kandhong 发表于 2014-12-28 20:06
qh8600 老师：
       您的VBA已收悉，在测试的过程中发现一个问题，恳请老师给予指教！！
       当数 ...

数字对号入座问题.rar (17.61 KB, 下载次数: 10)

2014-12-28 20:52 上传

点击文件名下载附件
这样试试

跳转到最佳答案楼层

qh8600

1. Sub demo()
   
2.     Dim ar, br(), x As String
   
3.     ar = Range("c4:k" & Cells(Rows.Count, 3).End(3).Row)
   
4.     ReDim br(1 To UBound(ar), 1 To 12)
   
5.     For i = 1 To UBound(ar)
   
6.         x = ""
   
7.         For j = 1 To UBound(ar, 2)
   
8.             x = x & "," & ar(i, j)
   
9.         Next
   
10.         For r = 1 To 12
    
11.             If InStr(x, Format(r, "00")) Then
    
12.                 br(i, r) = "'" & Format(r, "00")
    
13.             End If
    
14.         Next
    
15.     Next
    
16.     Columns("l:w").ClearContents
    
17.     Range("l4").Resize(UBound(br), 12) = br
    
18. End Sub

复制代码

附件楼下

qh8600

数字对号入座问题.rar (13.51 KB, 下载次数: 5)

2014-12-28 19:01 上传

点击文件名下载附件
楼主试试

kandhong

qh8600 发表于 2014-12-28 19:02
楼主试试

qh8600 老师：
       您的VBA已收悉，在测试的过程中发现一个问题，恳请老师给予指教！！
       当数据区为文本格式时，VBA测试正常；而当数据区为常规格式时，VBA测试出错。
       如图所示：
      

qh8600

kandhong 发表于 2014-12-28 20:06
qh8600 老师：
       您的VBA已收悉，在测试的过程中发现一个问题，恳请老师给予指教！！
       当数 ...

数字对号入座问题.rar (17.61 KB, 下载次数: 10)

2014-12-28 20:52 上传

点击文件名下载附件
这样试试

雪舞子

貌似做个循环嵌套即可：

1. Sub test()
   
2.     Dim arr, brr() As String, i%, j%, k%
   
3.     arr = Range("c4:k" & Cells(Rows.Count, 3).End(3).Row)
   
4.     ReDim brr(1 To UBound(arr), 1 To 12) As String
   
5.     For i = 1 To UBound(arr)
   
6.         For j = 1 To 12
   
7.             For k = 1 To 9
   
8.                 If Val(arr(i, k)) = j Then
   
9.                     brr(i, j) = arr(i, k)
   
10.                     Exit For
    
11.                 End If
    
12.             Next
    
13.         Next
    
14.     Next
    
15.     [y4].Resize(UBound(brr), 12) = brr
    
16. End Sub
    

复制代码

djyjysxxs

Sub test()
    Dim ar(), br()
    ar = Range("c4:k" & Cells(Rows.Count, 3).End(3).Row)
    ReDim br(1 To UBound(ar), 1 To 12)
    For i% = 1 To UBound(ar)
        For j% = 1 To UBound(ar, 2)
            br(i, ar(i, j)) = "'" & ar(i, j)
        Next
    Next
    Columns("l:w").ClearContents
    Range("l4").Resize(i - 1, 12) = br
End Sub

grf1973

1. Sub test()
   
2.     Dim ar(), br()
   
3.     ar = Range("c4:k" & [k65536].End(3).Row)
   
4.     ReDim br(1 To UBound(ar), 1 To 12)
   
5.     For Each x In ar()
   
6.         n = n + 1
   
7.         If n = UBound(ar) + 1 Then n = 1
   
8.         br(n, x) = "'" & x
   
9.     Next
   
10.     Columns("l:w").ClearContents
    
11.     Range("l4").Resize(UBound(br), 12) = br
    
12. End Sub
    

复制代码

kandhong

qh8600 发表于 2014-12-28 20:52
这样试试

qh8600 老师：
       正解，太感谢了！！

kandhong

雪舞子 发表于 2014-12-28 21:58
貌似做个循环嵌套即可：

雪舞子老师：
     非常感谢您给予VBA，太强大了，收藏了！！