有序提取行数据到工作表的问题

杨小妹

附件 有序提取行数据到工作表附件.rar (609.56 KB, 下载次数: 12)

2025-2-1 08:14 上传

点击文件名下载附件

谢谢老师！

ykcbf1100

附件供参考。。。
更新一下。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2025.2.1
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set sh = ThisWorkbook.Sheets("Sheet0")
   
6.     arr = sh.[a1].CurrentRegion
   
7.     For i = 1 To UBound(arr)
   
8.         s = arr(i, 2)
   
9.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
   
10.         d(s)(i) = i
    
11.     Next
    
12.     On Error Resume Next
    
13.     For Each k In d.keys
    
14.         Set sht = Sheets("Sheet" & k)
    
15.         sht.Cells.Clear
    
16.         If Err <> 0 Then
    
17.             Set sht = Sheets.Add(After:=Sheets(Sheets.Count))
    
18.             sht.Name = "Sheet" & k
    
19.         End If
    
20.         ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
21.         m = 0
    
22.         For Each kk In d(k).keys
    
23.             m = m + 1
    
24.             For j = 1 To UBound(arr, 2)
    
25.                 brr(m, j) = arr(kk, j)
    
26.             Next
    
27.         Next
    
28.         sht.[a1].Resize(m, UBound(arr, 2)) = brr
    
29.     Next
    
30.     sh.Activate
    
31.     Application.ScreenUpdating = True
    
32.     MsgBox "OK！"
    
33. End Sub
    

复制代码

杨小妹

ykcbf1100 发表于 2025-2-1 09:06
参与一下。。。

老师新年好，谢谢帮助。试了一下，拆分的结果少了一列数据，F列。拆分时，只到表1表2表3和表49，其它工作表都是空的。

gwjkkkkk

ykcbf1100

杨小妹 发表于 2025-2-1 09:43
老师新年好，谢谢帮助。试了一下，拆分的结果少了一列数据，F列。拆分时，只到表1表2表3和表49，其它工作 ...

改好了。。。

gwjkkkkk

请参考附件。。。

杨小妹

ykcbf1100 发表于 2025-2-1 09:56
改好了。。。

谢谢老师并祝新春快乐，全家幸福！

杨小妹

gwjkkkkk 发表于 2025-2-1 10:02
请参考附件。。。

谢谢老师并祝新春快乐，全家幸福！

quqiyuan

参与一下，仅供参考。。。