伊莉討論區

標題: 請幫我簡化資料擷取時間並排序的步驟 [打印本頁]
作者: zbc231    時間: 2019-12-12 11:24 PM     標題: 請幫我簡化資料擷取時間並排序的步驟

[attach]129800155[/attach]
原始資料為左邊，為了擷取出時間並補空號排序，目前我用了五個步驟，因此想請問各位高手，能更簡化嗎？
目前第一步：從原始資料右邊將數字擷取出來，並排序。


  1. Sub 留下數字()
  2.     For i = 1 To 30
  3.         '1.字數迴圈範圍
  4.         s = ""
  5.         For j = 1 To Len(Cells(i, "C"))
  6.             '2.判斷是否為數字
  7.             If VBA.Asc(Mid(Cells(i, "C"), j, 1)) > 47 And VBA.Asc(Mid(Cells(i, "C"), j, 1)) < 58 Then
  8.                 '3.如果是就+1
  9.                 s = s & Mid(Cells(i, "C"), j, 1)
  10.             End If
  11.         Next
  12.         '4.傳給B欄i列的儲存格
  13.         Cells(i, "B") = s
  14.     Next
  15.     Worksheets("簽到表").Range("C1:I30").ClearContents
  16.     Range("A1:B30").Select
  17. Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
  18. OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
  19. :=xlStroke, DataOption1:=xlSortNormal
  20. End Sub
複製代碼
第二步：為了擷取時間，利用空格將資料切成3分，為避免蓋掉剛剛擷取出的號碼，所以我先插入三行空白。
  1. Sub insert()
  2. With Range("B:D")
  3.     .insert xlShiftDown
  4.     .ClearFormats
  5. End With
  6. End Sub
複製代碼
第三步：利用資料中日期、上午、時間中的空格，將資料分成3分。只是這個寫法，資料較少時，有時會跳出偵錯；沒跳出偵錯，最後兩筆資料則沒分割到，只能手動貼上。
  1. Sub MySplit()

  3. For i = 1 To Len(Cells(1, "A"))
  4.   ' 取得原始資料
  5.   rawData = Cells(i, 1)

  7.   ' 使用 Split 分割欄位
  8.   fieldArray = Split(rawData, " ")

  10.   ' 將各個欄位填入對應的儲存格
  11.   For j = 0 To 2
  12.     Cells(i, j + 2).Value = fieldArray(j)
  13.   Next j
  14. Next i

  16. End Sub
複製代碼
第四步：刪除原來的時間資料根被分割出來的前兩欄資料。
  1. Sub delete()
  2. Columns("A:C").Select
  3. Selection.delete Shift:=xlToLeft
  4. End Sub
複製代碼
第五步：因為資料中間有跳號，所以將空號補齊。這個寫法如果開頭是4，他就會補齊4以後的空號，但1-3號就不會補，該怎麼修正才會從1號開始補齊呢？
  1. Sub 補空號()
  2.   Dim xRow&, xR As Range, j&, Jm&, Xm&
  3.   xRow = [B30].End(xlUp).Row
  4.   If xRow = 1 Then Exit Sub
  5.   Application.ScreenUpdating = False
  6.   '↓檢測缺號，補足列數及填入編號
  7.   For j = xRow - 1 To 2 Step -1
  8.       Set xR = Range("B" & j)
  9.       Xm = Val(xR(2)) - Val(xR)
  10.       If Xm > 1 Then
  11.         xR(2).Resize(Xm - 1).EntireRow.insert
  12.         xR.AutoFill Destination:=xR.Resize(Xm), Type:=xlFillSeries
  13.         Jm = Jm + Xm - 1
  14.       End If
  15.   Next j
  16.   Application.ScreenUpdating = True
  17.   End Sub
複製代碼
以上為小弟目前為了擷取資料，根據網路上可找到的資訊所使用了方式，不知道各位高手能幫小弟精簡這些步驟，謝謝！


作者: tryit244178    時間: 2019-12-14 02:42 PM

本帖最後由 tryit244178 於 2019-12-27 10:09 AM 編輯

這還不簡單，你只要這樣做
  1. Public Sub Simplify()
  2.         留下數字()
  3.         insert()
  4.         MySplit()
  5.         delete()
  6.         補空號()
  7. End Sub
複製代碼
你看，五個步驟就變成一個步驟了

話說這樣東找西找，能夠湊出來，你也蠻厲害的
提供另一個給你，不過有點小缺點…不難，你可以自已寫看看
  1. Public Sub GetTimeAndSort()
  2.    Dim index As Integer
  3.   
  4.    For i = 1 To 30
  5.       index = Int(Right(Cells(i, "C"), 2))
  6.       Worksheets("目的地").Range("A" & index) = Trim(Right(Cells(i, "A"), 8))
  7.       Worksheets("目的地").Range("B" & index) = Cells(i, "C")
  8.    Next
  9. End Sub
複製代碼
因為我現在跳槽到LibreOffice，沒在用一點都不硬的Office，所以沒辦法測程式碼對不對。
如果有錯就…自已改一下XD
作者: zbc231    時間: 2019-12-24 08:28 AM

tryit244178 發表於 2019-12-14 02:42 PM
這還不簡單，你只要這樣做你看，五個步驟就變成一個步驟了

話說這樣東找西找，能夠湊出來，你也蠻厲 ...

謝謝你！我趕緊來試試看！



歡迎光臨 伊莉討論區 (http://aaa.eyny.com/) Powered by Discuz!