[發問] 分離單號

PJChen

大大好,
E欄的單號,含有2個"-",作為分離基準,單號分離至R、S、T三欄中
T欄單號: 3碼+"-" (不足3碼,前面補0)
S欄單號: 4碼+"-" (不足4碼,前面補0)
R欄單號: 3碼 (不足3碼,前面補0)

ex:
採購單號碼        末碼        中間碼        單號
886-1215-283        283        1215-        886-
872-1305-017        017        1305-        872-
010-0105-547        547        0105-        010-

請問要如何寫這個程式?   分離單號_Split.rar (151.35 KB)

下載次數: 14

2021-7-4 23:10

1. Sub 分離單號()
   
2. Dim xB As Workbook, R&, xD, Arr2, Arr3, Arr4
   
3. R = Cells(Rows.Count, "E").End(xlUp).Row
   
4. If R <= 2 Then Exit Sub
   
5. Set xB = Workbooks("分離單號_Split.xlsx")
   
6. With xB.Sheets("北區")
   
7.      R = .Cells(Rows.Count, 1).End(xlUp).Row - 1
   
8.     If R > 0 Then arr = Split([E2], "-")
   
9.      If R > 0 Then Arr2 = Split([E2], "-").Resize(R).Value
   
10.      If R > 0 Then Arr3 = Split([E2], "-").Resize(R).Value
    
11.      If R > 0 Then Arr4 = Split([E2], "-").Resize(R).Value
    
12. End With
    
13.     xB.Sheets("北區").[r2].Resize(R).Value = Arr2
    
14.     xB.Sheets("北區").[s2].Resize(R).Value = Arr3
    
15.     xB.Sheets("北區").[t2].Resize(R).Value = Arr4
    
16. Next
    
17. End Sub

複製代碼

singo1232001

Sub aaa()
r = Cells(Rows.Count, "E").End(3).Row

Dim ar
ReDim ar(3 To r, 1 To 3)
For i = 3 To r
x = Cells(i, "e")
If x <> "" Then
If Len(x) - Len(Replace(x, "-", "")) = 2 Then

x0 = Split(x, "-")
ar(i, 1) = "'" & x0(2)
ar(i, 2) = x0(1) & "-"
ar(i, 3) = x0(0) & "-"

End If
End If
Next

Range("r3").Resize(r - 2, 3) = ar
End Sub

n7822123

回復 1# PJChen

看你原本的資料好像沒有需要補"0" 的地方?

Sub 分離單號()
Dim Arr, R&
Arr = Range([E2], [E2].End(4))
If Arr(UBound(Arr), 1) = "" Then Exit Sub   '沒資料
Columns("R:T").NumberFormatLocal = "@"
ReDim Brr(1 To UBound(Arr), 1 To 3)
For R = 2 To UBound(Arr)
  If Arr(R, 1) Like "*-*-*" Then
    Brr(R, 1) = Split(Arr(R, 1), "-")(2)
    Brr(R, 2) = Split(Arr(R, 1), "-")(1) & "-"
    Brr(R, 3) = Split(Arr(R, 1), "-")(0) & "-"
    If Len(Brr(R, 1)) < 3 Then Brr(R, 1) = String(3 - Len(Brr(R, 1)), "0") & Brr(R, 1)
    If Len(Brr(R, 2)) < 5 Then Brr(R, 2) = String(5 - Len(Brr(R, 2)), "0") & Brr(R, 2)
    If Len(Brr(R, 3)) < 4 Then Brr(R, 3) = String(4 - Len(Brr(R, 3)), "0") & Brr(R, 3)
  End If
Next R
[R2].Resize(UBound(Brr), 3) = Brr
End Sub

samwang

回復 1# PJChen

請測試看看，謝謝

Sub test()
Dim Arr, Brr(), a, w$, i&, j%
Columns("R:T").NumberFormatLocal = "@"
Arr = Range([E2], [E2].End(4))
ReDim Brr(1 To UBound(Arr), 1 To 3)
For i = 2 To UBound(Arr)
    a = Split(Arr(i, 1), "-")
    If UBound(a) < 2 Then GoTo 99
    For j = 0 To UBound(a)
        w = Split(Arr(i, 1), "-")(j)
        If j = 0 Then
            If Len(w) < 3 Then Brr(i, 3) = "0" & w & "-" Else Brr(i, 3) = w & "-"
        ElseIf j = 1 Then
            If Len(w) < 4 Then Brr(i, 2) = "0" & w & "-" Else Brr(i, 2) = w & "-"
        ElseIf j = 2 Then
            If Len(w) < 3 Then Brr(i, 1) = "0" & w Else Brr(i, 1) = w
        End If
    Next
99: Next
[R2].Resize(UBound(Brr), 3) = Brr
End Sub

PJChen

回復 3# n7822123
回復 2# singo1232001
回復 4# samwang

謝謝三位, 結果都很完美！
請問N大 (n7822123)
能否幫忙解說以下程式紅字? 我對UBound的數字對應很不理解@@
.NumberFormatLocal = "@"
ReDim Brr(1 To UBound(Arr), 1 To 3)
For R = 2 To UBound(Arr)

准提部林

回復 5# PJChen


ubound(arr) ... 緃向行數...相當于指定範圍的rows.count
ubound(arr,2) ... 橫向欄數...相當于指定範圍的columns.count

for i = 2 to ~~
arr的範圍包含第一行標題, 第一行不須處理, 故從2起始~~

准提部林

若都是純數字~~
Sub TEST_A1()
Dim Arr, i&, j%, Vr, TR
Arr = Range([g1], [e65536].End(3))
Vr = Array("000-", "0000-", "000")
For i = 3 To UBound(Arr)
    TR = Split(Arr(i, 1) & "--", "-")
    For j = 0 To 2
        Arr(i - 2, 3 - j) = IIf(IsNumeric(TR(j)), Format(TR(j), Vr(j)), "")
    Next j
Next i
With [r3].Resize(UBound(Arr) - 2, 3)
     .NumberFormatLocal = "@"
     .Value = Arr
End With
End Sub

'================================

PJChen

回復 7# 准提部林
好久不見....准大好,
程式運作OK

能否解紅字?
Arr = Range([g1], [e65536].End(3))
另程式中沒有R:T, 為何它能自動置入呢?

n7822123

回復 5# PJChen

定義Brr是個2維陣列，它的1維上界等於Arr陣列的1為上界(Rows)，2維界限是1~3(Columns)

以下這個範例程式可以幫你了解 陣列的宣告，以及陣列的界限區間

直接執行就可以了，看訊息並對比程式

Sub Ex()
Dim Arr(1 To 10)                  '定義一個一維陣列Arr
Str1 = "Arr的界限=" & LBound(Arr) & "~" & UBound(Arr) & vbCrLf & vbCrLf
Dim Brr(2 To 20, 3 To 30)   '定義一個二維陣列Brr
Str2 = "Brr的1維界限=" & LBound(Brr, 1) & "~" & UBound(Brr, 1) & vbCrLf
Str3 = "Brr的2維界限=" & LBound(Brr, 2) & "~" & UBound(Brr, 2) & vbCrLf
MsgBox Str1 & Str2 & Str3
End Sub

PJChen

回復 9# n7822123

執行後,覺得很抽象@@