[已解决]vba能否实现附件里的效果

三田

Book1.rar (27.64 KB, 下载次数: 26)

2013-1-29 23:07 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-1-30 16:28

用这个吧。如果J列没有内容，不会清空J列前面的内容。
(, 下载次数: 8)

上传

点击文件名下载附件

跳转到最佳答案楼层

hwc2ycy

K列的是怎么回事？

hwc2ycy

每次刷新后，J列数据是重新放还是接着原来的放》？

hwc2ycy

1. Sub test()
   
2.     Dim arr, arrTemp, arrLen&, Item
   
3.     Dim LastRow&, jRow&
   
4.     LastRow = Cells(Rows.Count, 2).End(xlUp).Row
   
5.     Range("j:j").ClearContents
   
6.     arr = Range("b1:b" & LastRow)
   
7.     jRow = Cells(Rows.Count, "j").End(xlUp).Row
   
8.     Application.ScreenUpdating = False
   
9.     For Each Item In arr
   
10.         If Item Like "### *" Then
    
11.             Item = Replace(Item, "  ", " ")
    
12.             arrTemp = Split(Item, " ")
    
13.             arrLen = UBound(arrTemp) + 1
    
14.             Cells(jRow, "j").Resize(arrLen) = WorksheetFunction.Transpose(arrTemp)
    
15.             ActiveWindow.ScrollRow = jRow
    
16.             jRow = jRow + arrLen
    
17.         End If
    
18.     Next
    
19.     Application.ScreenUpdating = True
    
20.     MsgBox "提取完成"
    
21. End Sub

复制代码

三田

hwc2ycy 发表于 2013-1-30 08:59

不刷新时是这样的: B5:B38(001到986放 J 列)
                             B43:B117(006到987放 K 列)
                             B129:B140(014到986放L列),  等

hwc2ycy

1. Sub test()
   
2.     Dim arr, arrTemp, arrLen&, Item, Col&
   
3.     Dim LastRow&, jRow&
   
4.     LastRow = Cells(Rows.Count, 2).End(xlUp).Row
   
5.     Range("j1", Cells(1, Columns.Count).End(xlToLeft)).EntireColumn.ClearContents
   
6.     arr = Range("b1:b" & LastRow)
   
7.     jRow = Cells(Rows.Count, "j").End(xlUp).Row
   
8.     Application.ScreenUpdating = False
   
9.     Col = 9
   
10.     For Each Item In arr
    
11.         If InStr(Item, "#") Then
    
12.             Col = Col + 1
    
13.             jRow = Cells(Rows.Count, Col).End(xlUp).Row
    
14.         End If
    
15.         If Item Like "### *" Then
    
16.             Item = Replace(Item, "  ", " ")
    
17.             arrTemp = Split(Item, " ")
    
18.             arrLen = UBound(arrTemp) + 1
    
19.             Cells(jRow, Col).Resize(arrLen) = WorksheetFunction.Transpose(arrTemp)
    
20.             jRow = jRow + arrLen
    
21.         End If
    
22.     Next
    
23.     Application.ScreenUpdating = True
    
24.     MsgBox "提取完成"
    
25. End Sub

复制代码

三田

hwc2ycy 发表于 2013-1-30 09:58

<div class="blockcode"><blockquote>Sub test()   这句是红色的字

三田

hwc2ycy 发表于 2013-1-30 09:58

运行不了,能不能再看下

hwc2ycy

三田 发表于 2013-1-30 10:31
Sub test()   这句是红色的字

这是啥？

hwc2ycy

你复制后面的代码。
<div class="blockcode"><blockquote>把这个删除掉。