搜尋顏色標為紅色的字串,並將抓取字串相加後存在另一個表
PS:
Sub CHECK_CONTENT_LENGTH_SEPERATE()
--這個sub 是將同一個儲存格抓到的連續字串次數 逐次 複製在 另一個表的幾個欄位
諸位使用以下便可
Sub CHECK_CONTENT_LENGTH_TOGETHER()
(智慧財產權, 轉用者請獲得原作者同意後方可使用,
並標注出處 與 本文超連結）
'''''程式碼如下
''程序
''將鼠標點擊域搜尋的工作表(worksheet)
''由 sub 新增工作表執行
'''
'''***************************************************************
Sub 新增工作表()
Dim 可新增 As Boolean
''判斷新增工作表是否存在, 無則增加
可新增 = True
'MsgBox "原始可新增=" & 可新增
新增工作表名稱 = "不用新增"
MsgBox "目前工作表 " & ActiveSheet.Name
目前工作表 = ActiveSheet.Name
For k = 1 To Worksheets.Count
If Worksheets(k).Name = ActiveSheet.Name & "(簡化)" Then
可新增 = False
End If
'MsgBox k & " ws.Name=" & Worksheets(k).Name
'MsgBox "結果=" & 可新增
Next k
If 可新增 = True Then
新增工作表名稱 = ActiveSheet.Name & "(簡化)"
Set NewSheet = Worksheets.Add
NewSheet.Name = 新增工作表名稱
Worksheets(目前工作表).Activate
End If
MsgBox "新增工作表名稱=" & 新增工作表名稱
'''MsgBox 新增工作表
Call CHECK_CONTENT_LENGTH_TOGETHER
End Sub
Sub CHECK_CONTENT_LENGTH_TOGETHER() ' 判斷儲存格字元數,並累加紅色字串
Dim 字串長度 As Long
Dim 連續紅色字串 As String
Dim 相對列位 As Integer
Dim 可新增 As Boolean
Dim 新增工作表 As String
新增工作表 = ActiveSheet.Name & "(簡化)"
原工作表 = ActiveSheet.Name
連續紅色字串 = ""
字串數 = 0
'
''K是欄位 號
For j = 1 To 20 ''''' 列編號 外圈 用以一列掃描完 後 換下一列
For k = 1 To 6 ''''欄編號 偵測是否有在那個欄位
字串長度 = 0
'MsgBox "儲存格" & j & " ： " & K & " ： " & 字串長度 & ActiveCell.Text
'MsgBox "字串長度=" & 字串長度
字串長度 = Len(Worksheets(原工作表).Cells(j, k))
Worksheets(原工作表).Cells(j, k).Activate
Debug.Print "儲存格" & j & " ： " & k & " ： " & "字串長度＝" & 字串長度 & "內容＝" & Cells(j, k)
連續紅色字串 = ""
If 字串長度 > 0 Then
For i = 1 To 字串長度 ''' I 變數 用以逐字偵測 紅色 字元
' Debug.Print "第" & I & "字元=" & ActiveCell.Characters(I, 1).Font.Color
' MsgBox "第" & I & "字元=" & ActiveCell.Characters(I, 1).Text & " ;顏色" & ActiveCell.Characters(I, 1).Font.Color
''''''A 段 ''' ' 判段字串顏色=5 ,並累加字串
Worksheets(原工作表).Cells(j, k).Activate
If ActiveCell.Characters(i, 1).Font.Color = 255 Then
連續紅色字串 = 連續紅色字串 & ActiveCell.Characters(i, 1).Text
Debug.Print "連續紅色字串 中間＝" & i & 連續紅色字串
'MsgBox "連續紅色字串=" & 連續紅色字串
'Debug.Print 連續紅色字串
End If
'''''''A尾''''''''''''''
''''B段'''''''最後一個字元是紅色,直接印出
If i = 字串長度 Then
''''''''''''''''''''''''''''''相對列位 = ActiveCell.Row
'''''' ' 字串數 = 字串數 + 1 ''''''''''''''
''''''''''''''''Worksheets(新增工作表).Cells(相對列位, 字串數) = 連續紅色字串
''''''''''''''''連續紅色字串 = 連續紅色字串 & ActiveCell.Characters(I, 1).Text
Worksheets(新增工作表).Cells(j, k).Value = 連續紅色字串
Debug.Print "連續紅色字串 結尾＝" & i & 連續紅色字串
連續紅色字串 = ""
End If
Next i
End If
'相對列位 = ActiveCell.Row
''Worksheets(新增工作表).Cells(J, k) = 連續紅色字串
'MsgBox "連續紅色字串=" & 連續紅色字串
Next k
Next j
End Sub
Sub CHECK_CONTENT_LENGTH_SEPERATE() ' 判斷儲存格字元數,並累加紅色字串 次數
Dim 字串長度 As Integer
Dim 連續紅色字串 As String
Dim 相對列位 As Integer
Dim 可新增 As Boolean
新增工作表 = ActiveSheet.Name & (簡化)
連續紅色字串 = ""
字串數 = 0
'ActiveCell.Characters.Count
字串長度 = ActiveCell.Characters.Count
MsgBox "字串長度=" & 字串長度
For i = 1 To 字串長度
' Debug.Print "第" & I & "字元=" & ActiveCell.Characters(I, 1).Font.Color
' MsgBox "第" & I & "字元=" & ActiveCell.Characters(I, 1).Text & " ;顏色" & ActiveCell.Characters(I, 1).Font.Color
If ActiveCell.Characters(i, 1).Font.Color = 255 Then ' 判段字串顏色=5 ,並累加字串
連續紅色字串 = 連續紅色字串 & ActiveCell.Characters(i, 1).Text
'MsgBox "連續紅色字串=" & 連續紅色字串
Debug.Print 連續紅色字串
End If
If ActiveCell.Characters(i, 1).Font.Color = 255 And i = 字串長度 Then
相對列位 = ActiveCell.Row
字串數 = 字串數 + 1 ''''''''''''''
Worksheets(新增工作表).Cells(相對列位, 字串數) = 連續紅色字串
連續紅色字串 = ""
End If
If ActiveCell.Characters(i, 1).Font.Color <> 255 Then
相對列位 = ActiveCell.Row
字串數 = 字串數 + 1 ''''''''''''''''''
Worksheets(新增工作表).Cells(相對列位, 字串數) = 連續紅色字串
連續紅色字串 = ""
End If
Next i
'MsgBox "連續紅色字串=" & 連續紅色字串
End Sub
************************
可能遇到的困難
1.Mac 顏色與MS 顏色編碼可能不同,所以設定顏色可能會變,字元碼也會不同
==>可以利用即時視窗輸入 來確認顏色碼 (列與欄位根據自己的文本內容）
print cells(11,3).text
答：
print cells(11,3).font.color
255
2.老是忘記 用 來驅動 目前工作欄
Worksheets(原工作表).Cells(j, k).Activate
3.判斷每個字顏色 (關鍵技巧,找了很多網頁沒有現成的全文判別)
字串長度 作為 迴圈 來進行 每個字確認
使用到 activecell.characters(start , length).font.color
4.最後一個字如還是紅色 則必須判別是否為最後一個字元,否則不會印出
**********************************
沒有留言:
張貼留言