標題: [發問] 序號(籃號)如何截取某儲存格中後2數 [打印本頁]

---

作者: BV7BW    時間: 2021-6-4 11:27     標題: 序號(籃號)如何截取某儲存格中後2數

如何將序號(籃號)B2改為截取C2最後2數為序號(籃號)
將籃號(序號)(B欄)更改以編號(C欄)後2位數
如後面有S則以S前2位數

Sub 派車表_輸入()
Dim DD, CC$, Arr, Brr, i&, j%, N&, xD
Call 派車表_清除
DD = [D1]: CC = [B1]
If Not IsDate(DD) Then MsgBox "**請輸入日期!!  ": Exit Sub
If CC = "" Then MsgBox "**請輸入[車編]!!  ": Exit Sub
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([工作表2!L1], [工作表2!A65536].End(xlUp))
ReDim Brr(1 To UBound(Arr), 1 To 4)
For i = 2 To UBound(Arr)
    If Arr(i, 12) <> DD Or Arr(i, 10) <> CC Then GoTo 101
    PNo = Arr(i, 11): If xD(PNo) = 1 Then GoTo 101
    xD(PNo) = 1:  N = N + 1: Arr(N, 2) = Format(N, "00")     '有資料時Arr的第2欄位，自動產生序號
    For j = 1 To 4
        Brr(N, 1) = Arr(i, 1)
        Brr(N, 3) = Arr(i, 2)
        Brr(N, 2) = Arr(N, 2)
    Next j
    Brr(N, 4) = Arr(i, 11)
101: Next i
If N = 0 Then MsgBox "**沒有符合的資料!!  ": Exit Sub
With Sheets("工作表1")
     .[A3].Resize(N, UBound(Brr, 2)) = Brr
     .Range("A1:G" & N + 3).Name = "'" & .Name & "'!Print_Area"
     .Range("1:3").Name = "'" & .Name & "'!Print_Titles"
End With
End Sub
[attach]33376[/attach]

---

作者: samwang    時間: 2021-6-4 19:45

本帖最後由 samwang 於 2021-6-4 19:48 編輯

回復 1# BV7BW

請測試看看，不知是否為您的需求，謝謝。

Sub 派車表_輸入1()
Dim DD, CC$, Arr, Brr, i&, j%, N&, xD
Call 派車表_清除
DD = [D1]: CC = [B1]
If Not IsDate(DD) Then MsgBox "**請輸入日期!!  ": Exit Sub
If CC = "" Then MsgBox "**請輸入[車編]!!  ": Exit Sub
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([工作表2!L1], [工作表2!A65536].End(xlUp))
ReDim Brr(1 To UBound(Arr), 1 To 4)
For i = 2 To UBound(Arr)
    If Arr(i, 12) <> DD Or Arr(i, 10) <> CC Then GoTo 101
    PNo = Arr(i, 11): If xD(PNo) = 1 Then GoTo 101
    xD(PNo) = 1:  N = N + 1
   If InStr(Arr(i, 2), "A") Then
        Brr(N, 2) = Format(Right(Arr(i, 2), 2), "00")
    Else
        Brr(N, 2) = Format(Mid(Right(Arr(i, 2), 3), 1, 2), "00")
    End If
    Brr(N, 1) = Arr(i, 1)
    Brr(N, 3) = Arr(i, 2)
    Brr(N, 4) = Arr(i, 11)
101: Next i
If N = 0 Then MsgBox "**沒有符合的資料!!  ": Exit Sub
With Sheets("工作表1")
     .[A3].Resize(N, UBound(Brr, 2)) = Brr
     .Range("A1:G" & N + 3).Name = "'" & .Name & "'!Print_Area"
     .Range("1:3").Name = "'" & .Name & "'!Print_Titles"
End With
End Sub

---

作者: BV7BW    時間: 2021-6-4 19:51

[b   復 2# samwang
謝謝 S大大
我先測試運用在向你報告
謝謝

---

作者: hcm19522    時間: 2021-6-5 10:00

參考   
https://blog.xuite.net/hcm19522/twblog/589814048

---

作者: BV7BW    時間: 2021-6-7 06:25

回復 4# hcm19522
謝謝 hcm 先進前輩
堤供資訊.實用可循 謝謝

---

作者: BV7BW    時間: 2021-6-8 09:21

回復 2# samwang
  S大大你好
經測試後有個問題請問
原本是以If InStr(Arr(i, 2), "A") Then 及 Brr(N, 2) = Format(Right(Arr(i, 2), 2), "00")
    改以If InStr(Arr(i, 2), "籃") Then 及 Brr(N, 2) = Format(Right(Arr(i, 2), 4), "00")後
    可出現"籃A11".可以運用
但不知改 Brr(N, 2) = Format(Mid(Right(Arr(i, 2), 3), 1, 2), "00")之哪裡
    才可出現籃AS00
     [attach]33378[/attach]請示指教 謝謝

---

作者: n7822123    時間: 2021-6-8 13:11

回復 1# BV7BW



這一串有點混亂，我還是以1樓需求來看就好，修改"派車表_輸入"這個程序

如何將序號(籃號)B2改為截取C2最後2數為序號(籃號)
將籃號(序號)(B欄)更改以編號(C欄)後2位數
如後面有S則以S前2位數

不一樣的地方我也用紅色標注

Sub 派車表_輸入()
Dim DD, CC$, Arr, Brr, i&, j%, N&, xD
Call 派車表_清除
DD = [D1]: CC = [B1]
If Not IsDate(DD) Then MsgBox "**請輸入日期!!  ": Exit Sub
If CC = "" Then MsgBox "**請輸入[車編]!!  ": Exit Sub
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([工作表2!L1], [工作表2!A65536].End(xlUp))
ReDim Brr(1 To UBound(Arr), 1 To 4)
For i = 2 To UBound(Arr)
    If Arr(i, 12) <> DD Or Arr(i, 10) <> CC Then GoTo 101
    PNo = Arr(i, 11): If xD(PNo) = 1 Then GoTo 101
    xD(PNo) = 1
    N = N + 1
    For j = 1 To 4
        Brr(N, 1) = Arr(i, 1)
        SS$ = Replace(Arr(i, 2), "S", "")
        Brr(N, 2) = Right(SS, 2)
        Brr(N, 3) = Arr(i, 2)
    Next j
    Brr(N, 4) = Arr(i, 11)
101: Next i
If N = 0 Then MsgBox "**沒有符合的資料!!  ": Exit Sub
With Sheets("工作表1")
     .[A3].Resize(N, UBound(Brr, 2)) = Brr
     .Range("A1:G" & N + 3).Name = "'" & .Name & "'!Print_Area"
     .Range("1:3").Name = "'" & .Name & "'!Print_Titles"
End With
Columns("B").NumberFormatLocal = "00"
End Sub

---

作者: samwang    時間: 2021-6-8 13:46

回復 6# BV7BW

請再測試看看，謝謝

Sub 派車表_輸入2()
Dim DD, CC$, Arr, Brr, i&, j%, N&, xD
Call 派車表_清除
DD = [D1]: CC = [B1]
If Not IsDate(DD) Then MsgBox "**請輸入日期!!  ": Exit Sub
If CC = "" Then MsgBox "**請輸入[車編]!!  ": Exit Sub
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([工作表2!L1], [工作表2!A65536].End(xlUp))
ReDim Brr(1 To UBound(Arr), 1 To 4)
For i = 2 To UBound(Arr)
    If Arr(i, 12) <> DD Or Arr(i, 10) <> CC Then GoTo 101
    PNo = Arr(i, 11): If xD(PNo) = 1 Then GoTo 101
    xD(PNo) = 1:  N = N + 1
   If InStr(Arr(i, 2), "S") Then
        Brr(N, 2) = Mid(Split(Arr(i, 2), "-")(1), 1, Len(Split(Arr(i, 2), "-")(1)) - 1)
    Else
        Brr(N, 2) = Split(Arr(i, 2), "-")(1)
    End If
    Brr(N, 1) = Arr(i, 1)
    Brr(N, 3) = Arr(i, 2)
    Brr(N, 4) = Arr(i, 11)
101: Next i
If N = 0 Then MsgBox "**沒有符合的資料!!  ": Exit Sub
With Sheets("工作表1")
     .[A3].Resize(N, UBound(Brr, 2)) = Brr
     .Range("A1:G" & N + 3).Name = "'" & .Name & "'!Print_Area"
     .Range("1:3").Name = "'" & .Name & "'!Print_Titles"
End With
End Sub

---

作者: BV7BW    時間: 2021-6-9 12:51

回復 8# samwang
謝謝S大大
完全正確運用
感謝指導 謝謝

---

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