在线急等，愿意红包支付

刘志红

求将图1的excel数据自动转换为图2的数据

abc123281

呵呵 可以实现  红包多少

刘志红

20元大大的红包啊

活在理想的世界

1. Sub d()
   
2. Dim arr, brr(): arr = Sheet2.Range("a1").CurrentRegion: Sheet3.Cells.ClearContents
   
3. For c = 2 To UBound(arr, 2)
   
4.     For r = 4 To UBound(arr)
   
5.         If arr(r, c) = "Y" Then j = j + 1: ReDim Preserve brr(1 To 2, 1 To j): brr(1, j) = arr(r, 1): brr(2, j) = arr(3, c)
   
6.     Next
   
7. Next
   
8. Sheet3.Range("A3").Resize(j, 2) = WorksheetFunction.Transpose(brr): Sheet3.Range("A3").Sort Sheet3.Range("A2"), xlAscending, , , , , , xlNo
   
9. End Sub

复制代码

活在理想的世界

1111111111111111111111111111111111111111

活在理想的世界

本人微信号：Hansen160740；ID：活在理想的世界。

我是第一个回复的，把钱打给我。

hhjjpp

这个何难，公式就行
可惜附件07，打不开

活在理想的世界

1. Sub d()
   
2. Dim arr(), brr()
   
3. arr = Sheet2.Range("a1").CurrentRegion '定义  原始数据表  的整个区域为数组
   
4. Sheet3.Cells.ClearContents '清空  结果表  的所有数据
   
5. For c = 2 To UBound(arr, 2) '外循环是数组的最大列数，也就是   原始数据表   的最大列数J列(10列)
   
6.     For r = 4 To UBound(arr) '内循环是数组的行数，也就是   原始数据表  的最大行数(目前是8行，以后有多少行就是多少)
   
7.         If arr(r, c) = "Y" Then '如果数组的值等于"Y"
   
8.             j = j + 1 '开始计数
   
9.             ReDim Preserve brr(1 To 2, 1 To j) '定义二维动态数组，目的是为了把结果装进去
   
10.             brr(1, j) = arr(r, 1) '结果数组的第一行第J列就是  原始数据表数组的A列数据
    
11.             brr(2, j) = arr(3, c) '结果数组的第二行第J列就是 原始数据表数组的第3行数据
    
12.         End If
    
13.     Next
    
14. Next
    
15. Sheet3.Range("A3").Resize(j, 2) = WorksheetFunction.Transpose(brr) '将结果数组赋值给  结果表的区域，因为动态数组只能动态增加列，所以必须用Transpose转置，Transpose函数为VBA调用工作表函数
    
16. Sheet3.Range("A3").Sort Sheet3.Range("A2"), xlAscending, , , , , , xlNo '按照结果表的A列进行升序排序
    
17. End Sub

复制代码

活在理想的世界

红包已收到。。。。。。。。。。。

abc123281

呵呵  我的不要钱

1. Sub test()
   
2. Dim arr, brr(1 To 1000, 1 To 2)
   
3. With Worksheets("原始数据")
   
4.     rw = .[a65536].End(xlUp).Row
   
5.     arr = .Range("a3:j" & rw)
   
6.     For i = 2 To UBound(arr)
   
7.        For j = 2 To 10
   
8.        arr(i, j) = Replace(arr(i, j), "  ", "")
   
9.           If arr(i, j) = "Y" Then
   
10.              n = n + 1
    
11.              brr(n, 1) = arr(i, 1)
    
12.              brr(n, 2) = arr(1, j)
    
13.           End If
    
14.        Next
    
15.     Next
    
16. End With
    
17. With Worksheets("结果")
    
18.   .[a3].Resize(n, 2) = brr
    
19. End With
    
20. End Sub

复制代码