麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 資料剖析+加框線 [打印本頁]

作者: v03586 時間: 2017-7-29 06:26 標題: 資料剖析+加框線

請問各位高手大大, 如何將這段功能轉為程式碼
1.  有點類似資料剖析的概念, 因為格式不一定 , 但規則確定的是刪除從左邊數過來兩個『-』
   保留紅色的字體

2.  畫線後判斷不同的加粗體分辨

[attach]27557[/attach]

[attach]27556[/attach]

作者: GBKEE 時間: 2017-7-29 08:55

本帖最後由 GBKEE 於 2017-7-29 09:58 編輯

回復 1# v03586
試試看

Option Explicit
Sub Ex()
Dim E As Range, sp As Variant, i As Integer, Msg As Boolean, St As String
St = ",AAP,PPA,QQP,POO," '末碼規則
With Range("h2").CurrentRegion
'Range.CurrentRegion 屬性傳回 Range 物件，該物件代表目前的區域。目前區域是指以任意空白列及空白欄的組合為邊界的範圍。唯讀的。
For Each E In .Cells
sp = Split(E.Value, "-")
'Split 函數傳回一個陳列索引從零開始的一維陣列 , 它包含指定數目的子字串
Msg = InStr(St, "," & UCase(UBound(sp)) & ",")
For i = 0 To UBound(sp) - IIf(Msg, 2, 1)
E = Replace(E, sp(i) & "-", "")
'Replace 函數傳回一個字串 , 該字串中指定的子字串已被取代成另一子字串, 並且取代發生的次數也是指定的
Next
Next
.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium, ColorIndex:=xlAutomatic
For Each E In .Cells
With E.Borders(9) 'xlInsideVertical
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = IIf(E.Offset(1) <> E, xlThick, xlMedium)
End With
Next
End With
End Sub

複製代碼

作者: v03586 時間: 2017-7-29 09:32

本帖最後由 v03586 於 2017-7-29 09:37 編輯

回復 2# GBKEE

感謝版大的支援,
想問一下, 他的末碼規則不一定是QQP 的話, 也可能是別的AAP 之類的 , 不固定, 是還要在加一串

For i = 0 To UBound(sp) - IIf(InStr(E, "QQP"), 2, 1) and UBound(sp) - IIf(InStr(E, "AAP"), 2, 1)

複製代碼

這樣嗎?? 確定固定規則模式從左邊數來兩個『-』是要刪除的

作者: v03586 時間: 2017-7-29 10:26

本帖最後由 v03586 於 2017-7-29 10:28 編輯

回復 2# GBKEE

板大加入了末碼規則後, 程式跑完變成只保留末碼, 『AAP , QQP 』
不是變成保留像圖片中保留紅色字體部分 QQ
我按F8 去跑會變成下面這段把他變成 AAP , QQP

For i = 0 To UBound(sp) - IIf(Msg, 2, 1)
E = Replace(E, sp(i) & "-", "")
'Replace 函數傳回一個字串 , 該字串中指定的子字串已被取代成另一子字串, 並且取代發生的次數也是指定的
Next

複製代碼

作者: GBKEE 時間: 2017-7-29 12:29

回復 4# v03586

再上傳檔案看看
2#程式碼執行後如圖

[attach]27560[/attach]

作者: v03586 時間: 2017-7-29 12:46

本帖最後由 v03586 於 2017-7-29 12:56 編輯

回復 5# GBKEE

如圖片說明 , 唯一找的到不變的規則, 就是從左邊往右算兩個『-』不保留
如果從右邊算, 有的會有末碼QQP 等字碼
[attach]27561[/attach]

   有的字串會有三個『-』  e.g.
   XX-XXXX-XXXX-QQP
   有的字串只有兩個『-』 e.g.
XX-XXXX-XXXX
要保留的依循有效規律規則, 從左邊往右算2個『-』

[attach]27562[/attach]

作者: GBKEE 時間: 2017-7-29 15:25

回復 6# v03586

修改了, 試試看

Option Explicit
Sub Ex()
Dim E As Range, sp As Variant, i As Integer
With Range("h2").CurrentRegion
'Range.CurrentRegion 屬性傳回 Range 物件，該物件代表目前的區域。目前區域是指以任意空白列及空白欄的組合為邊界的範圍。唯讀的。
For Each E In .Cells
sp = Split(E.Value, "-")
'Split 函數傳回一個陳列索引從零開始的一維陣列 , 它包含指定數目的子字串
If UBound(sp) > 2 Then ' 規則, 有第二個『-』,才處裡
For i = 0 To IIf(UBound(sp) > 2, UBound(sp) - 2, 1)
E = Replace(E, sp(i) & "-", "")
'Replace 函數傳回一個字串 , 該字串中指定的子字串已被取代成另一子字串, 並且取代發生的次數也是指定的
Next
End If
Next
.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium, ColorIndex:=xlAutomatic
For Each E In .Cells
With E.Borders(9) 'xlInsideVertical
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = IIf(E.Offset(1) <> E, xlThick, xlMedium)
End With
Next
End With
End Sub

複製代碼

作者: Kubi 時間: 2017-8-1 12:03

回復 6# v03586
另種解法，請參考。
[attach]27582[/attach]

作者: 准提部林 時間: 2017-8-1 21:20

TT = "09-SAF5-1111K-QQP"
TT = Split(Replace(TT, "-", "+", , 2), "+")(2)
MsgBox TT

TT = "09-C231-100WK"
TT = Split(Replace(TT, "-", "+", , 2), "+")(2)
MsgBox TT

作者: Hsieh 時間: 2017-8-2 14:53

Sub ex()
Dim A As Range
Set d = CreateObject("Scripting.Dictionary")
For Each A In Range("H2:H15")
st = Split(Application.WorksheetFunction.Substitute(A, "-", Chr(10), 2), Chr(10))(1)
A.Offset(, 1) = st '寫入
If IsEmpty(d(st)) Then '同文字儲存格範圍暫存
Set d(st) = A.Offset(, 1)
Else
Set d(st) = Union(d(st), A.Offset(, 1))
End If
Next
For Each ky In d.keys
For i = 7 To 12
With d(ky).Borders(i) '畫框線
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = IIf(i > 10, xlThin, xlMedium)
End With
Next
Next
End Sub

複製代碼

回復 6# v03586

作者: v03586 時間: 2017-8-4 04:51

回復 7# GBKEE

感謝板大的協助
第九行這一段

If UBound(sp) >= 2 Then

複製代碼

改成這一段就可以完成了 !!! 再次感謝~~

作者: v03586 時間: 2017-8-4 04:55

回復 v03586
Hsieh 發表於 2017-8-2 14:53

感謝板大的提供另一種方式, 對於畫線的方式, 又學到一招板大的方式撰寫

作者: v03586 時間: 2017-8-4 12:10

回復 8# Kubi

感謝大大的提供 !!

作者: 准提部林 時間: 2017-8-4 22:40

Sub test()
Dim xR As Range, xH As Range
For Each xR In [H2:H19]
　　If xH Is Nothing Then xR = Split(Replace(xR, "-", "+", , 2), "+")(2): Set xH = xR
　　If xR(2) <> "" Then xR(2) = Split(Replace(xR(2), "-", "+", , 2), "+")(2)
　　If xR(2) <> xR Then
　　　　With Range(xR, xH)
　　　　　　　.Borders.Weight = 3
　　　　　　　If .Count > 1 Then .Borders(12).Weight = 2
　　　　End With
　　　　Set xH = xR(2)
　　End If
Next
End Sub
　
　

作者: v03586 時間: 2017-8-5 23:46

回復 14# 准提部林

請問一下, 我有依照我的額外需求做了一些小修改, 想請問一下
如果我要判斷畫線的資料欄位在D欄位 , 我如何修改讓他算整筆資料的最後一欄 ??
是加入下面這一段嗎???

.Range("D65536").End(xlUp).Row To 2 Step -1

複製代碼

再來我要畫線的範圍是A2欄到AD2欄

Dim xR As Range, xH As Range
For Each xR In [D2:D3000]
If xH Is Nothing Then Set xH = xR
If xR(2) <> xR Then
With Range(xR, xH)
.Borders.Weight = 4
If .Count > 1 Then .Borders(12).Weight = 2
End With
Set xH = xR(2)
End If
Next

複製代碼

作者: 准提部林 時間: 2017-8-6 09:13

本帖最後由准提部林於 2017-8-6 09:17 編輯

回復 15# v03586

For Each xR In Range([D2], [D65536].End(xlUp))
　　If xR.Row < 2 Then Exit Sub '當D2以下為空時,結束程序
　　或　If xR.Row < 2 Then Exit For '當D2以下為空時,跳出迴圈
　
Next

作者: v03586 時間: 2017-8-6 15:43

回復 16# 准提部林

請問一下大大, 修改後判斷式為D欄位只要有一樣的話細線, 不一樣的畫粗線來做分別
但是我的判斷一樣使用D欄位, 但話線的範圍要擴大A2欄位到AD2以下的欄位都要話線 , 請問要如何延伸呢?
判斷式一樣是由D欄位

Dim xxR As Range, xxH As Range
For Each xxR In Range([D2], [D65536].End(xlUp))
If xxR.Row < 2 Then Exit Sub
If xxH Is Nothing Then Set xxH = xxR
If xxR(2) <> xxR Then
With Range(xxR, xxH)
.Borders.Weight = 4
If .Count > 1 Then .Borders(12).Weight = 2
End With
Set xxH = xxR(2)
End If
Next

複製代碼

[attach]27590[/attach]

作者: 准提部林 時間: 2017-8-6 17:08

回復 17# v03586

有合併格？？？
上傳檔案再看看！！！
　

作者: v03586 時間: 2017-8-6 17:45

回復 18# 准提部林

抱歉, 沒有合併格, 合併格是我處理完畫線才合併格的 !!!

[attach]27592[/attach]

作者: 准提部林 時間: 2017-8-6 20:01

回復 19# v03586

Sub test()
Dim R, xR As Range, xH As Range, xE As Range, i&, V&
R = [D65536].End(xlUp).Row
For i = 2 To R
　　Set xR = Cells(i, "D")
　　If xH Is Nothing Then Set xH = Cells(i, "AD")
　　V = xR.MergeArea.Rows.Count
　　Set xE = xR(V)
　　If xR <> xE(2) Then
　　　　With Range(Cells(xE.Row, 1), xH)
　　　　　　　.Borders.Weight = 4
　　　　　　　If .Columns.Count > 1 Then .Borders(11).Weight = 2
　　　　　　　If .Rows.Count > 1 Then .Borders(12).Weight = 2
　　　　End With
　　　　Set xH = Cells(i + V, "AD")
　　End If
　　i = i + V - 1
Next i
End Sub

不管Ｄ欄有沒有合併格，都可以！！
　
　

作者: 准提部林 時間: 2017-8-6 20:07

回復 19# v03586

Sub test1()
Dim R, xR As Range, xH As Range
R = [D65536].End(xlUp).Row
For Each xR In Range([D2], [D65536].End(xlUp))
　　If xH Is Nothing Then Set xH = Cells(xR.Row, "AD")
　　If xR(2) <> xR Then
　　　With Range(xR(1, -2), xH)
　　　　　　.Borders.Weight = 4
　　　　　　If .Columns.Count > 1 Then .Borders(11).Weight = 2
　　　　　　If .Rows.Count > 1 Then .Borders(12).Weight = 2
　　　End With
　　　Set xH = Cells(xR.Row + 1, "AD")
　　End If
Next
End Sub

只適用于無合併格！！！
　

作者: v03586 時間: 2017-8-9 15:30

本帖最後由 v03586 於 2017-8-9 15:31 編輯

回復 20# 准提部林

感謝板大提供的兩個版本!!! 最後我選擇有合併格的 !!!
可否再請教大大一個問題...

在我Test report的EXCEL "機台數"的分頁, 去做一個類似分析資料, 因為我知道樞紐分析用錄製的
   只要他的參考資料有新增沒有被錄製進去的資訊就會跳出錯誤
   [attach]27608[/attach] [attach]27603[/attach]


    程式步驟是, 開啟Test Report 再打開"參考資料" →  再按產生報表
   程式會從參考資料抓取要的資料到Test report 去做資料彙整
   直到Moudle3『機台數』只是把參考資料中我要的資料抓過來, 再做一個篩選
   剩下的資料要做分析的
   Q1:  能否將Moudle3 篩選完的資料在同一個分頁『機台數』呈現出  上圖的資料呢?
            如果PKG是空白代表機台待料, 可否把空白字眼換成" 待料 "
      [attach]27604[/attach]

   Ｑ2: 能否將分析完的資料再匯入FMC 與 ENG 的資料表內
         [attach]27605[/attach]
      比對每一欄的J欄的PKG 如果相符就把分析完的機台數帶入F欄位
      [attach]27606[/attach]

[attach]27607[/attach]

作者: 准提部林 時間: 2017-8-9 20:18

回復 22# v03586

我的office版本無法正常執行程式,
應該幫不上!!!

作者: v03586 時間: 2017-8-27 04:16

回復 20# 准提部林

板大 , 我想再請教一個問題
這些資料條件都是在連續性的情況下
假設我如果當中資料有不定時空白的資料, 如何處理呢? 如下圖
[attach]27675[/attach]

我目前發現只要有空白的他就會自動結束迴圈

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