返回列表 上一主題 發帖

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

lionliu

帖子
97 
主題
26 
精華
0 
積分
158 
點名
0  
作業系統
windows 
軟體版本
office2010 
閱讀權限
20 
性別
男 
來自
taichung 
註冊時間
2010-9-12 
最後登錄
2019-8-29 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2012-4-9 15:35 | 只看該作者

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

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

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
2#
發表於 2012-4-9 17:16 | 只看該作者
回復 1# lionliu
需要依遍號順序重排區塊
你須要說明一下吧

TOP

hugh0620
　暱稱: VBA向前衝

高中生Rank: 3Rank: 3

帖子
559 
主題
58 
精華
0 
積分
626 
點名
0  
作業系統
win8 
軟體版本
office2013 
閱讀權限
50 
性別
男 
來自
TW 
註冊時間
2010-11-22 
最後登錄
2024-6-14 
3#
發表於 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
複製代碼
學習才能提升自己

TOP

hugh0620
　暱稱: VBA向前衝

高中生Rank: 3Rank: 3

帖子
559 
主題
58 
精華
0 
積分
626 
點名
0  
作業系統
win8 
軟體版本
office2013 
閱讀權限
50 
性別
男 
來自
TW 
註冊時間
2010-11-22 
最後登錄
2024-6-14 
4#
發表於 2012-4-9 17:56 | 只看該作者
回復 1# lionliu

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

data11.rar (16.93 KB)

學習才能提升自己

TOP

lionliu

帖子
97 
主題
26 
精華
0 
積分
158 
點名
0  
作業系統
windows 
軟體版本
office2010 
閱讀權限
20 
性別
男 
來自
taichung 
註冊時間
2010-9-12 
最後登錄
2019-8-29 
5#
發表於 2012-4-9 18:18 | 只看該作者
謝謝 hugh0620 和 G 大喔抱歉我說明的不清楚 ，我抓回來試一下再跟2為大大報告喔
lionliu

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
255  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-11-24 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
6#
發表於 2012-4-9 18:49 | 只看該作者
回復 1# lionliu


    play.gif
學海無涯_不恥下問

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
7#
發表於 2012-4-9 20:27 | 只看該作者
回復 5# lionliu
你這好像是 進口艙單 要分提單號碼 內容有 貨物的Mark, 貨物的名稱, 貨物的件數,
請附上完整分提單號碼 艙單  來試試看

TOP

lionliu

帖子
97 
主題
26 
精華
0 
積分
158 
點名
0  
作業系統
windows 
軟體版本
office2010 
閱讀權限
20 
性別
男 
來自
taichung 
註冊時間
2010-9-12 
最後登錄
2019-8-29 
8#
發表於 2012-4-10 13:15 | 只看該作者
謝謝Hsieh你的方法有想過但是因為選取範圍問題一直想不到好的方法。
GBKEE大哥我這是國外客戶要求文件INVOICE要如此所以很麻煩SORRY
才想說看是否可介VBA來處理。
lionliu

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
255  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-11-24 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
9#
發表於 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
複製代碼
學海無涯_不恥下問

TOP

lionliu

帖子
97 
主題
26 
精華
0 
積分
158 
點名
0  
作業系統
windows 
軟體版本
office2010 
閱讀權限
20 
性別
男 
來自
taichung 
註冊時間
2010-9-12 
最後登錄
2019-8-29 
10#
發表於 2012-4-10 16:40 | 只看該作者
回復 9# Hsieh

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

TOP

        靜思自在 : 君子為目標，小人為目的。
返回列表 上一主題