PJChen

　暱稱: PJ

帖子: 913
主題: 150
精華: 0
積分: 1089
點名: 0
作業系統: win10
軟體版本: office 2019
閱讀權限: 50
性別: 女
註冊時間: 2011-8-28
最後登錄: 2023-7-19

論壇榮譽勳章論壇贊助勳章

1^# 跳轉到 » 倒序看帖

打印

字體大小: tT

發表於 2021-7-4 23:11 | 只看該作者

[發問] 分離單號

大大好,
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)

Sub 分離單號()
Dim xB As Workbook, R&, xD, Arr2, Arr3, Arr4
R = Cells(Rows.Count, "E").End(xlUp).Row
If R <= 2 Then Exit Sub
Set xB = Workbooks("分離單號_Split.xlsx")
With xB.Sheets("北區")
R = .Cells(Rows.Count, 1).End(xlUp).Row - 1
If R > 0 Then arr = Split([E2], "-")
If R > 0 Then Arr2 = Split([E2], "-").Resize(R).Value
If R > 0 Then Arr3 = Split([E2], "-").Resize(R).Value
If R > 0 Then Arr4 = Split([E2], "-").Resize(R).Value
End With
xB.Sheets("北區").[r2].Resize(R).Value = Arr2
xB.Sheets("北區").[s2].Resize(R).Value = Arr3
xB.Sheets("北區").[t2].Resize(R).Value = Arr4
Next
End Sub

複製代碼

樓主熱帖

singo1232001

　暱稱: 熱狗慶

中學生 Rank: 2

帖子: 354
主題: 5
精華: 0
積分: 387
點名: 0
作業系統: windows7
軟體版本: vba,vb,excel2007
閱讀權限: 20
性別: 男
註冊時間: 2017-1-8
最後登錄: 2024-8-2

論壇榮譽勳章論壇贊助勳章

2^#

發表於 2021-7-5 00:14 | 只看該作者

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

TOP

n7822123

　暱稱: 阿龍

中學生 Rank: 2

帖子: 406
主題: 8
精華: 0
積分: 453
點名: 0
作業系統: WINDOWS 7
軟體版本: 2007
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2015-2-7
最後登錄: 2021-7-31

3^#

發表於 2021-7-5 00:31 | 只看該作者

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

程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2024-10-30

4^#

發表於 2021-7-5 08:03 | 只看該作者

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

TOP

PJChen

　暱稱: PJ

大學生 Rank: 4

帖子: 913
主題: 150
精華: 0
積分: 1089
點名: 0
作業系統: win10
軟體版本: office 2019
閱讀權限: 50
性別: 女
註冊時間: 2011-8-28
最後登錄: 2023-7-19

論壇榮譽勳章論壇贊助勳章

5^#

發表於 2021-7-5 17:34 | 只看該作者

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

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2834
主題: 10
精華: 0
積分: 2890
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-27

6^#

發表於 2021-7-5 18:57 | 只看該作者

回復 5# PJChen

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

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

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2834
主題: 10
精華: 0
積分: 2890
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-27

7^#

發表於 2021-7-5 19:34 | 只看該作者

若都是純數字~~
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

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

TOP

PJChen

　暱稱: PJ

大學生 Rank: 4

帖子: 913
主題: 150
精華: 0
積分: 1089
點名: 0
作業系統: win10
軟體版本: office 2019
閱讀權限: 50
性別: 女
註冊時間: 2011-8-28
最後登錄: 2023-7-19

論壇榮譽勳章論壇贊助勳章

8^#

發表於 2021-7-5 20:25 | 只看該作者

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

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

TOP

n7822123

　暱稱: 阿龍

中學生 Rank: 2

帖子: 406
主題: 8
精華: 0
積分: 453
點名: 0
作業系統: WINDOWS 7
軟體版本: 2007
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2015-2-7
最後登錄: 2021-7-31

9^#

發表於 2021-7-6 00:29 | 只看該作者

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

程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

TOP

PJChen

　暱稱: PJ

大學生 Rank: 4

帖子: 913
主題: 150
精華: 0
積分: 1089
點名: 0
作業系統: win10
軟體版本: office 2019
閱讀權限: 50
性別: 女
註冊時間: 2011-8-28
最後登錄: 2023-7-19

論壇榮譽勳章論壇贊助勳章

10^#

發表於 2021-7-6 00:46 | 只看該作者

本帖最後由 PJChen 於 2021-7-6 00:56 編輯

回復 9# n7822123

執行後,覺得很抽象@@

TOP