Board logo

標題: 特定區塊依編號重新排列問題 [打印本頁]
作者: lionliu    時間: 2012-4-9 15:35     標題: 特定區塊依編號重新排列問題

各位大哥好
小弟碰到一個區塊須依編號重新排列的問題，音箱不到好方法現在用手動處裡
想請教各位大大要如何做較好:dizzy: [attach]10361[/attach]
作者: GBKEE    時間: 2012-4-9 17:16

回復 1# lionliu
需要依遍號順序重排區塊
你須要說明一下吧
作者: hugh0620    時間: 2012-4-9 17:53

回復 2# GBKEE

    G大~ 他的資料~ 我在處理上是有一些問題的~
    在每個區塊的空排列中~ 為非空白~ 處理起來蠻怪的~
    我是用手動先把空白列DETEL~ 再用程式碼來跑~
    請你在修改比較簡便的方式~
  1. Private Sub CommandButton1_Click()
  2. Dim A As Integer
  3. Dim B As Integer
  4. Dim D As Integer

  6. A = InputBox("請輸入開始列")   '15   140
  7. B = InputBox("請輸入結束列")   '134  256

  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      '清除要排序的資料區

  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)

  26.                     If R.Offset(J, 8) <> "" Then
  27.                        Range("V" & A + J) = R.Offset(0 + J, 8)
  28.                     End If

  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)

  41.                     If R.Offset(J, 8) <> "" Then
  42.                        Range("V" & A1 + J) = R.Offset(0 + J, 8)
  43.                     End If

  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    時間: 2012-4-9 17:56

回復 1# lionliu

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

謝謝 hugh0620 和 G 大喔抱歉我說明的不清楚 ，我抓回來試一下再跟2為大大報告喔
作者: Hsieh    時間: 2012-4-9 18:49

回復 1# lionliu


    [attach]10369[/attach]
作者: GBKEE    時間: 2012-4-9 20:27

回復 5# lionliu
你這好像是 進口艙單 要分提單號碼 內容有 貨物的Mark, 貨物的名稱, 貨物的件數,
請附上完整分提單號碼 艙單  來試試看
作者: lionliu    時間: 2012-4-10 13:15

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

回復 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    時間: 2012-4-10 16:40

回復 9# Hsieh

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



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)