[發問] 序號(籃號)如何截取某儲存格中後2數

BV7BW

如何將序號(籃號)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
派車表序號修訂.zip (43.86 KB)

下載次數: 14

2021-6-4 11:27

samwang

回復 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

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

hcm19522

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

BV7BW

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

BV7BW

回復 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
      派車表序號修訂.zip (42.33 KB)

下載次數: 4

2021-6-8 09:21

請示指教 謝謝

n7822123

回復 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

回復 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

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