請幫我簡化資料擷取時間並排序的步驟

zbc231

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

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()
   
2. 
   
3. For i = 1 To Len(Cells(1, "A"))
   
4.   ' 取得原始資料
   
5.   rawData = Cells(i, 1)
   
6. 
   
7.   ' 使用 Split 分割欄位
   
8.   fieldArray = Split(rawData, " ")
   
9. 
   
10.   ' 將各個欄位填入對應的儲存格
    
11.   For j = 0 To 2
    
12.     Cells(i, j + 2).Value = fieldArray(j)
    
13.   Next j
    
14. Next i
    
15. 
    
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

這還不簡單，你只要這樣做

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

tryit244178 發表於 2019-12-14 02:42 PM

下載: 訪客無法瀏覽下載點，請先 註冊 或 登入會員

這還不簡單，你只要這樣做你看，五個步驟就變成一個步驟了

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

...

瀏覽完整內容，請先 註冊 或 登入會員