有则提行自动上移

xing_chen

老师，您好！有表。原数据表的格式不变，但数据时有时无。我希望提取的数据，则，有数据的提，没有的数据的公司则在提取的表中不显示，且有数据的公司上下紧凑在一起，无空行。敬请老师赐教。谢谢！

nicleyuan

结果要放在不同的sheet里？

xing_chen

nicleyuan 发表于 2023-2-13 15:36
结果要放在不同的sheet里？

谢谢老师阅读！原表也可以

nicleyuan

老师不敢当，你三个截图，生成的结果都在I到K列。要生成8月的结果，难道要覆盖掉7月的？

xing_chen

nicleyuan 发表于 2023-2-13 15:45
老师不敢当，你三个截图，生成的结果都在I到K列。要生成8月的结果，难道要覆盖掉7月的？

是每月1次。生存的位置是我红框标注位置

xing_chen

nicleyuan 发表于 2023-2-13 15:45
老师不敢当，你三个截图，生成的结果都在I到K列。要生成8月的结果，难道要覆盖掉7月的？

你提示的对。因为我原想过，那样的话就要另表生存，要紧凑一起并用空列间隔。这难度就大了。现在你提醒的对。既然求助了，就一起解决。谢谢老师

ykcbf1100

字典嵌字典

xing_chen

ykcbf1100 发表于 2023-2-13 16:19
字典嵌字典

谢谢老师！运行如愿！

nicleyuan

try it

fzxba

1. Sub test0()
   
2.   Dim ar, br(), cr
   
3.   Dim i, j, p, x, y
   
4.   Columns("I:K").Clear
   
5.   ar = Range("A1").CurrentRegion.Value
   
6.   ReDim br(1 To UBound(ar), 1 To 3)
   
7.   br(1, 1) = ar(1, 1)
   
8.   br(1, 3) = ar(1, 2)
   
9.   For j = 3 To UBound(ar, 2)
   
10.     y = 1
    
11.     br(1, 2) = ar(1, j)
    
12.     cr = Array(1, j, 2)
    
13.     For i = 2 To UBound(ar)
    
14.       If Len(ar(i, j)) Then
    
15.         y = y + 1
    
16.         For x = 0 To UBound(cr)
    
17.           br(y, x + 1) = ar(i, cr(x))
    
18.         Next
    
19.       End If
    
20.     Next
    
21.     With Cells(p + 1, "I").Resize(y, UBound(br, 2))
    
22.       .Columns(3).NumberFormatLocal = "@"
    
23.       .HorizontalAlignment = xlCenter
    
24.       .Value = br
    
25.     End With
    
26.     p = p + y + 1
    
27.   Next
    
28. End Sub

复制代码