各類課程訓練單位+專業單位

2021-9-20 第二次更新

EXCEL VBA 上網自動抓取資料+匯入各個工作表

這裡可以參考到網上的,改天好好來看看

Excel VBA抓取儲存格內不同顏色部分字串

搜尋顏色標為紅色的字串,並將抓取字串相加後存在另一個表

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.最後一個字如還是紅色 則必須判別是否為最後一個字元,否則不會印出

**********************************