返回列表 上一主題 發帖

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

回復 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. A = InputBox("請輸入開始列")   '15   140
  6. B = InputBox("請輸入結束列")   '134  256

  7. If A >= 1 And B >= A Then
  8.    For Each R In Sheet1.Range("C" & A & ":C" & B)   '因C欄位的資料是文字,先轉換成數字
  9.        Range("M" & R.Row) = R.Value
  10.    Next
  11. C = Application.Max(Sheet1.Range("M:M"))            '抓取計算的最大值
  12. Sheet1.Range("M" & A & ":M" & B).ClearContents      '清除要排序的資料區

  13.    For I = 1 To C
  14.        For Each R In Sheet1.Range("C" & A & ":C" & B)
  15.         D = I
  16.         If R = D Then
  17.            If A1 = "" Then
  18.            Sheet1.Range("N" & A) = R.Value
  19.            J = 0
  20.            Do Until R.Offset(J + 1, 9) <> ""
  21.                     Range("P" & A + J) = R.Offset(0 + J, 2)

  22.                     If R.Offset(J, 8) <> "" Then
  23.                        Range("V" & A + J) = R.Offset(0 + J, 8)
  24.                     End If

  25.                     If R.Offset(J, 9) <> "" Then
  26.                     Range("W" & A + J) = R.Offset(0 + J, 9)
  27.                     End If
  28.                     J = J + 1
  29.            Loop
  30.            Else
  31.            Sheet1.Range("N" & A1) = R.Value
  32.            J = 0
  33.            Do Until R.Offset(J, 2) = ""
  34.                     Range("P" & A1 + J) = R.Offset(0 + J, 2)

  35.                     If R.Offset(J, 8) <> "" Then
  36.                        Range("V" & A1 + J) = R.Offset(0 + J, 8)
  37.                     End If

  38.                     If R.Offset(J, 9) <> "" Then
  39.                     Range("W" & A1 + J) = R.Offset(0 + J, 9)
  40.                     End If
  41.                     J = J + 1
  42.            Loop
  43.            End If
  44.            A1 = Range("P65536").End(xlUp).Offset(2, 0).Row
  45.         End If
  46.        Next
  47.    Next
  48. End If
  49. End Sub
複製代碼
學習才能提升自己

TOP

回復 1# lionliu

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

data11.rar (16.93 KB)

學習才能提升自己

TOP

        靜思自在 : 人生最大的成就是從失敗中站起來。
返回列表 上一主題