特定區塊依編號重新排列問題

lionliu

各位大哥好
小弟碰到一個區塊須依編號重新排列的問題，音箱不到好方法現在用手動處裡
想請教各位大大要如何做較好:dizzy: data.rar (17.45 KB)

data
下載次數: 16

2012-4-9 15:34

GBKEE

回復 1# lionliu
需要依遍號順序重排區塊
你須要說明一下吧

hugh0620

回復 2# GBKEE

    G大~ 他的資料~ 我在處理上是有一些問題的~
    在每個區塊的空排列中~ 為非空白~ 處理起來蠻怪的~
    我是用手動先把空白列DETEL~ 再用程式碼來跑~
    請你在修改比較簡便的方式~

1. Private Sub CommandButton1_Click()
   
2. Dim A As Integer
   
3. Dim B As Integer
   
4. Dim D As Integer
   
5. 
   
6. A = InputBox("請輸入開始列")   '15   140
   
7. B = InputBox("請輸入結束列")   '134  256
   
8. 
   
9. If A >= 1 And B >= A Then
   
10.    For Each R In Sheet1.Range("C" & A & ":C" & B)   '因C欄位的資料是文字，先轉換成數字
    
11.        Range("M" & R.Row) = R.Value
    
12.    Next
    
13. C = Application.Max(Sheet1.Range("M:M"))            '抓取計算的最大值
    
14. Sheet1.Range("M" & A & ":M" & B).ClearContents      '清除要排序的資料區
    
15. 
    
16.    For I = 1 To C
    
17.        For Each R In Sheet1.Range("C" & A & ":C" & B)
    
18.         D = I
    
19.         If R = D Then
    
20.            If A1 = "" Then
    
21.            Sheet1.Range("N" & A) = R.Value
    
22.            J = 0
    
23.            Do Until R.Offset(J + 1, 9) <> ""
    
24.                     Range("P" & A + J) = R.Offset(0 + J, 2)
    
25. 
    
26.                     If R.Offset(J, 8) <> "" Then
    
27.                        Range("V" & A + J) = R.Offset(0 + J, 8)
    
28.                     End If
    
29. 
    
30.                     If R.Offset(J, 9) <> "" Then
    
31.                     Range("W" & A + J) = R.Offset(0 + J, 9)
    
32.                     End If
    
33.                     J = J + 1
    
34.            Loop
    
35.            Else
    
36.            Sheet1.Range("N" & A1) = R.Value
    
37.            J = 0
    
38.            Do Until R.Offset(J, 2) = ""
    
39.                     Range("P" & A1 + J) = R.Offset(0 + J, 2)
    
40. 
    
41.                     If R.Offset(J, 8) <> "" Then
    
42.                        Range("V" & A1 + J) = R.Offset(0 + J, 8)
    
43.                     End If
    
44. 
    
45.                     If R.Offset(J, 9) <> "" Then
    
46.                     Range("W" & A1 + J) = R.Offset(0 + J, 9)
    
47.                     End If
    
48.                     J = J + 1
    
49.            Loop
    
50.            End If
    
51.            A1 = Range("P65536").End(xlUp).Offset(2, 0).Row
    
52.         End If
    
53.        Next
    
54.    Next
    
55. End If
    
56. End Sub

複製代碼

hugh0620

回復 1# lionliu

   因為您的資料有一些問題~
   所以~ 我的作法是先將空白列的地方先按DELETE清除資料~
   再來執行VBA~
   看看附件的結果是不是你要的結果~

lionliu

謝謝 hugh0620 和 G 大喔抱歉我說明的不清楚 ，我抓回來試一下再跟2為大大報告喔

Hsieh

回復 1# lionliu


   

下載 (1.92 MB)

2012-4-9 18:49

GBKEE

回復 5# lionliu
你這好像是 進口艙單 要分提單號碼 內容有 貨物的Mark, 貨物的名稱, 貨物的件數,
請附上完整分提單號碼 艙單  來試試看

lionliu

謝謝Hsieh你的方法有想過但是因為選取範圍問題一直想不到好的方法。
GBKEE大哥我這是國外客戶要求文件INVOICE要如此所以很麻煩SORRY
才想說看是否可介VBA來處理。

Hsieh

回復 8# lionliu

1. Sub Sort_Ex()
   
2. Dim Rng As Range
   
3. Columns("C:C").NumberFormat = "G/通用格式"
   
4. rs = Cells(Rows.Count, 5).End(xlUp).Row
   
5. r = 2: yn = False: s = 2
   
6. Do Until r >= rs
   
7. If InStr(Cells(r, 5), "P/O") > 0 Then
   
8.    If yn = False Then
   
9.       yn = True: x = 1
   
10.       Else
    
11.       yn = False
    
12.       Set Rng = Cells(s + 1, 3).Resize(x - 2, 10)
    
13.       k = Application.CountA(Rng.Columns(1))
    
14.       If k > 0 Then
    
15.       Rng.Columns(1).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
    
16.       Rng = Rng.Value
    
17.       Rng.Sort key1:=Rng(1), Header:=xlNo
    
18.       End If
    
19.       x = 0: s = r: r = r - 1
    
20.     End If
    
21. End If
    
22. r = r + 1: x = x + 1
    
23. Loop
    
24. End Sub

複製代碼

lionliu

回復 9# Hsieh

Hsieh大大  太厲害了 趕快來試一下若可以我晚上睡覺都會偷笑喔;P