檔案原始呈現畫面
http://www.pczone.com.tw/upload/002/1-1.jpg
資料需如圖重新排列
http://www.pczone.com.tw/upload/002/2-2.jpg

資料大約有4000行左右,請教各位前輩小弟應該如何撰寫這個vba程式??

贊助商連結

其實手動操作也還好，不會花太多時間...
以下先試試看吧~


Sub Macro1()
Set firstCell = [A21]
lastCol = 24 'X欄
lastRow = [I65536].End(xlUp).Row
With Range(firstCell, Cells(lastRow, lastCol))
.Columns(1).NumberFormat = "@"
.Replace " ", "", LookAt:=xlPart
.MergeCells = False
.Sort firstCell, xlAscending, Header:=xlNo, _
OrderCustom:=1, Orientation:=xlTopToBottom
End With
firstRow = firstCell.Row
lastRow = [M65536].End(xlUp).Row
With Range(firstCell, Cells(lastRow, lastCol))
.Columns.AutoFit
.Rows.AutoFit
For c = lastCol To 2 Step -1
If (lastRow - firstRow) < WorksheetFunction. _
CountBlank(.Columns(c)) Then
Columns(c).Delete
End If
Next c
.Cells(1).Select
End With
End Sub

謝謝 leonchou 兄幫忙!感恩
先前參考 leonchou 兄http://www.pczone.com.tw/showthread.php?t=140422
所撰寫的vba程式可是都看不懂,我想我這位程式幼教班的學生可要多多向這裡的前輩學習
小弟先前參考 leonchou 兄所撰寫的vba程式修改如下:
Sub summary()
Dim r&, sh As Worksheet
r = 5: On Error Resume Next
For Each sh In Worksheets
If sh.Name <> "summary" Then
If Cells(r, 1).Borders(xlEdgeBottom).LineStyle = xlDouble Then
Cells(r, 1).Resize(, 12).Insert Shift:=xlShiftDown
Cells(r, 1).Resize(, 12).FillDown
End If
For r1 = 5 To sh.[a65536].End(xlUp).Row
Cells(r, 1) = sh.Cells(r1, 1)
Cells(r, 2) = sh.Cells(r1, 2)
Cells(r, 3) = sh.Cells(r1, 3)
Cells(r, 7) = sh.Cells(r1, 10)
Cells(r, 9) = sh.Cells(r1, 11)
Cells(r, 3).MergeArea.UnMerge
Cells(r, 7).MergeArea.UnMerge
Cells(r, 9).MergeArea.UnMerge
Cells(r, 11).MergeArea.UnMerge
r = r + 1
Next r1
End If
Next sh
Range([A19], Cells(r - 1, 12)).Sort [B19], Key2:=[A19], Header:=xlNo
'恢復合併
For r = 5 To [a65536].End(xlUp).Row
Cells(r, 3).Resize(, 4).Merge
Cells(r, 7).Resize(, 2).Merge
Cells(r, 9).Resize(, 2).Merge
Cells(r, 11).Resize(, 2).Merge
Next r
Set sh = Nothing
End Sub

執行結果如下:

101000000 合約界面協調
101000000 合約界面協調
102000000 管線設施協調
102000000 管線設施協調
102010000 管線工程師
102010000 管線工程師
103000000 測量及放樣人員
103000000 測量及放樣人員
請問為何同一列資料會有兩列出現....(不解中)
問題1:想請問前輩可否告知這二個程式是如何運作???
問題2:程式初學者應該涉獵哪些書籍??
謝謝各位前輩指教

小弟先前參考 leonchou 兄所撰寫的vba程式修改如下:
......
......
請問為何同一列資料會有兩列出現....(不解中)
你找的這個例子根本不適合你阿，別管它了。
我上面寫的程式你試過了嗎? 哪裡不符合需求?

來解釋一下程式，你看看吧：
Sub Macro1()
　　Set firstCell = [A21] '設變數firstCell=處理範圍第一格
　　lastCol = 24 '設變數lastCol=處理範圍最後一欄的欄號(X欄)
　　lastRow = [I65536].End(xlUp).Row '設變數lastRow=處理範圍最後一筆的列號
　　With Range(firstCell, Cells(lastRow, lastCol)) '對處理範圍進行以下動作
　　　　.Columns(1).NumberFormat = "@" '第一欄(項目代號)設為文字格式,以便對齊
　　　　.Replace " ", "", LookAt:=xlPart '移除空格
　　　　.MergeCells = False '取消合併儲存格
　　　　.Sort firstCell, xlAscending, Header:=xlNo, _
　　　　　　OrderCustom:=1, Orientation:=xlTopToBottom '依項目代號排序
　　End With
　　firstRow = firstCell.Row '設變數firstRow=firstCell的列號
　　lastRow = [M65536].End(xlUp).Row '設變數lastRow=排序後處理範圍最後一筆的列號
　　With Range(firstCell, Cells(lastRow, lastCol)) '對排序後的處理範圍進行以下動作
　　　　.Columns.AutoFit '設定為最適欄寬
　　　　.Rows.AutoFit '設定為最適列高
　　　　For c = lastCol To 2 Step -1 '進行迴圈: 逐欄判斷
　　　　　　If (lastRow - firstRow) < WorksheetFunction. _
　　　　　　　　CountBlank(.Columns(c)) Then '如果該欄是空白
　　　　　　　　Columns(c).Delete '則刪除該欄
　　　　　　End If
　　　　Next c
　　　　.Cells(1).Select '最後選取第一格,結束
　　End With
End Sub
註：
這個程式只有處理原始資料的工作表，目的是先讓你看看處理結果可不可以。
有需要再決定是手動或自動轉入第二張工作表。


問題2:程式初學者應該涉獵哪些書籍??
關於書籍方面，因為沒看過什麼VBA的書，
只知道這裡有口碑不錯的Excel書，還有一些書評 --
http://www.excelhelp.net/bookreview/mybook2.htm
http://www.excelhelp.net/cgi-bin/fo...ums.cgi?forum=7
還有最近看到的 --
http://gb.twbts.com/index.php/topic,1883.0.html

其實個人覺得，要學好VBA，書本不是唯一的方法。
重點是多看多做多嘗試，從經驗中學習。
我不否認看書可以學到一些概念，但程式本身的語法說明就不盡然了。VBA線上說明是我主要的學習途徑，我的方法是以錄製巨集開始，看看它產生的程式是怎麼寫的。看程式或寫程式的時候，想要查閱說明，只要滑鼠點在想查的字上，然後按 F1 即可。VBA說明中包含程式語法、說明和範例，看多了自然就知道怎麼寫了。

這是我的方式，不一定適合你 -- 僅提供參考。
關於學習 VBA，可參考相關討論、我的經驗分享 --
http://www.pczone.com.tw/showthread.php?t=62955
http://www.pczone.com.tw/showthread.php?t=61219

最近忙翻了忘了回報使用狀況，希望 leonchou 兄原諒!
首先再次感謝 leonchou 兄幫忙!感恩(因為短短的幾行程式可以節省許多人力再核對資料方面)
回報使用情況:
問題1:
第一欄(項目代號)有9碼-10碼，(排列順序0123456789ABC...依序)
程式執行後會有一些(項目代號)順序錯置，如
(希望排列順序) (程式執行結果)
109020000 109020000
109030000 109020000
109040000 109020000
10A000000 200000000
10B000000 201000000
200000000 10A000000
201000000 10B000000

問題2:
第一欄(項目代號)如30E000000，40E000000，60E000000....等數值經過程式轉換成文字後會變成科學符號，3.00E+01，4.00E+01，6.00E+01

只加了一句，測試階段只貼部份程式碼以免佔篇幅。
你再試試看吧。

Sub Macro1()
　　......
　　......
　　With Range(firstCell, Cells(lastRow, lastCol))
　　　　.Columns(1).NumberFormat = "@"
　　　　'項目代號空格換為單引號以排序且防止變成科學符號
　　　　.Columns(1).Replace " ", "'", LookAt:=xlPart
　　　　.Replace " ", "", LookAt:=xlPart '移除空格
　　　　......
　　　　......
　　End With
　　......
　　......
　　......
End Sub

這個巨集程式蠻有意思的，
雖然leonchou兄說明的很清楚(綠色字)，
但是我還是不太懂，我有照表操練試了一下還真是方便，
那些指令OFFICE小幫手裡應該都會有說明吧。