把F列进行重新排列（其它的列不变）

gaoch35

F列都是两个及以上相连的单元格。要是F列有单个单元格的就把它删除掉
从F列的第一行开始排起，先排两个相连的单元格，再排三个相连的单元格，然后排四个相连的单元格......
把那些不相连的单元格空一行区分开来

bluexuemei

模拟一下结果吧。。。

gaoch35

bluexuemei 发表于 2014-11-24 10:23
模拟一下结果吧。。。

有图有真相

Vicel

1. Sub PX()
   
2.     i = 1
   
3.     Do
   
4.         n = Range("F" & i).End(xlDown).Row
   
5.         s = Range("F" & n).CurrentRegion.Rows.Count
   
6.         arr = Range("F" & n & ":F" & n + s)
   
7.         Range("H" & n).Resize(UBound(arr), 1) = s
   
8.         i = n + s
   
9.     Loop Until i > Range("F65536").End(xlUp).Row
   
10.     Columns("F:H").Select
    
11.     Selection.Sort Key1:=Range("H1"), Order1:=xlAscending, Header:=xlGuess, _
    
12.         OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
    
13.         :=xlPinYin, DataOption1:=xlSortNormal
    
14.     Columns("H").ClearContents
    
15. End Sub

复制代码

用到H列来做辅助列

bluexuemei

1. Sub t()
   
2. '需要安装ACTIVERUBY ，下载地址 http://www.artonx.org/data/asr/Ruby-2.1.1.msi
   
3. Set ojs = CreateObject("scriptcontrol"): ojs.Language = "rubyscript"
   
4. y = ojs.eval("def aa(aa);$aa=aa.flatten;end")
   
5. y = ojs.Run("aa", Sheet1.Range("f5", [f65536].End(3)).Value)
   
6. y = ojs.eval("$aa.chunk{|x|x!=nil}.select{|x|x[0]==true}.map(&:last).sort_by{|x|x.size}.flat_map{|x|x<<nil}.zip")
   
7. Sheet1.[h5].Resize(UBound(y)) = y
   
8. Set ojs = Nothing
   
9. 'Stop
   
10. End Sub

复制代码

gaoch35

数据换了，难度加大了，哪位大神能编VBA

gaoch35

Vicel 发表于 2014-11-24 11:52
用到H列来做辅助列

我把数据换了你的就用不了，你还能在编一个VBA吗，附件换了

Vicel

gaoch35 发表于 2014-11-24 15:32
我把数据换了你的就用不了，你还能在编一个VBA吗，附件换了

你想排哪一列？还是所有列都要排？

gaoch35

Vicel 发表于 2014-11-24 15:53
你想排哪一列？还是所有列都要排？

只排F列就可以了，其他的不变

Vicel

gaoch35 发表于 2014-11-24 16:06
只排F列就可以了，其他的不变

看效果如何？是否符合楼主要求

1. Sub PX()
   
2.     Cs = ActiveSheet.UsedRange.Columns.Count
   
3.     Rs = ActiveSheet.UsedRange.Rows.Count
   
4.     Brr = Columns("E"): Columns("E").ClearContents
   
5.     Crr = Columns("G"): Columns("G").ClearContents
   
6.     i = 1
   
7.     Do
   
8.         If Cells(i, 6) <> "" Then
   
9.             n = i
   
10.         Else
    
11.             n = Range("F" & i).End(xlDown).Row
    
12.         End If
    
13.         s = Range("F" & n).CurrentRegion.Rows.Count
    
14.         arr = Range("F" & n & ":F" & n + s)
    
15.         Range(Chr(Cs + 65) & n).Resize(UBound(arr), 1) = s
    
16.         i = n + s
    
17.     Loop Until i > Range("F65536").End(xlUp).Row
    
18.     Range("E1").Resize(UBound(Brr), 1) = Brr
    
19.     Range("G1").Resize(UBound(Crr), 1) = Crr
    
20.     Range(Cells(1, 1), Cells(Rs, Cs + 1)).Sort Key1:=Range(Chr(Cs + 65) & "1"), Order1:=xlAscending, Header:=xlGuess, _
    
21.         OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
    
22.         :=xlPinYin, DataOption1:=xlSortNormal
    
23.     Columns(Chr(Cs + 65)).ClearContents
    
24. End Sub

复制代码