作者singermath (singer)
看板Office
標題Re: [問題] 請問EXCEL資料彙整的問題
時間Sun Sep 9 16:05:30 2007
提供兩個VBA僅供參考
(剛學沒多久，若有錯請多包涵)
1. data2top() :對每一行把非空資料往上移動，直到該行往下無非空資料為止。
(僅針對 每一行的數值(數字或文字)
，若包含公式則不動作，如=a1*b3)
2. data2left():同上，不過是把資料往左邊移動。
可兩個搭配來用，如:先用1再用2。
(我預設範圍是用 usedrange ，可能會有點小問題
若知道確定範圍，可自行修改第3行
原本:Set rng=ActiveSheet.UsedRange
修改:Set rng=Range("a1:k100") 'a1:k100 是自訂範圍
程式碼如下:
Sub data2top()
Dim rng As Range, do_col As Range
Set rng = ActiveSheet.UsedRange
rng_col = rng.Columns.Count
j = 1
Do While j <= rng_col
i = 1
Do
Set do_col = ActiveSheet.Cells(i, j).Range("a1")
If IsEmpty(do_col.End(xlDown)) Then
Exit Do
ElseIf IsEmpty(do_col) Then
do_col.Value = do_col.End(xlDown).Value
do_col.End(xlDown).Clear
End If
i = i + 1
Loop
j = j + 1
Loop
MsgBox "done..."
End Sub
Sub data2left()
Dim rng As Range, do_row As Range
Set rng = ActiveSheet.UsedRange
rng_row = rng.Rows.Count
i = 1
Do While i <= rng_row
j = 1
Do
Set do_row = ActiveSheet.Cells(i, j).Range("a1")
If IsEmpty(do_row.End(xlToRight)) Then
Exit Do
ElseIf IsEmpty(do_row) Then
do_row.Value = do_row.End(xlToRight).Value
do_row.End(xlToRight).Clear
End If
j = j + 1
Loop
i = i + 1
Loop
MsgBox "done..."
End Sub
--
※ 發信站: 批踢踢實業坊(ptt.cc)
◆ From: 59.114.40.210
1F：推 windyfun:我試看看 謝 09/09 22:27