[發問] 以巨集抓取指定顏色資料

msmplay

下載 (65.06 KB)

2016-11-27 02:24

請問如何以巨集方式，按下上方【匯入】扭，即可將庫存活頁A:W欄所有的藍色字體與綠色字體的「品牌」與「庫存」
抓到A、B欄與D、E欄，例如左側，條件如下：

1. 只要抓藍字與綠字的品牌資料與庫存數，其餘顏色資料不需要。
2. 字體、粗體、大小都可能不一樣，所以希望以顏色區分即可。
3. 每天庫存資料數會有多有少，不能以每欄固定列數來抓。
例如 F:G欄的藍字庫存為F23:G42，但下次資料來源可能少一筆會變成F23:G40，但如果多一筆則變成F23:G44
4. 不用排序，所以只要將資料抓到A、B欄與D、E欄就好，從前往後、從後往前抓資料都沒差



測試檔.rar (23.81 KB)

下載次數: 5

2016-11-27 02:24

msmplay

回復 9# 准提部林


   准大~~~~非常感謝你yo

准提部林

回復 8# msmplay


多做一次就可以:
Xl0000024-V1.rar (21.87 KB)

下載次數: 5

2016-12-1 21:23

msmplay

回復 2# 准提部林


   准大~~不好意思又來打擾你了，可以請教一下如果小妹需要新增抓取條件，你可以幫我改一下嗎??

下載 (49.19 KB)

2016-12-1 20:43

Xl0000024.rar (20.42 KB)

下載次數: 2

2016-12-1 20:44

msmplay

回復 6# 准提部林


   准大~~~~~果然是顏色不一樣的問題，取得文字色碼後再修改一下，已經成功了~~~~~~~~~~~~~~~~~~超感謝超感謝超感謝你的yo

准提部林

回復 5# msmplay

選定一個儲存格, 執行以下取得文字色碼
Sub TEST()
MsgBox ActiveCell.Font.ColorIndex
End Sub

msmplay

回復 4# 准提部林

   准大~~~~可以請教一下在以上巨集內，我該怎麼修改我想指定的顏色呢?因為我發現好像是公司庫存表用色不統一的問題，謝謝你ㄛ~~~~

准提部林

回復 3# msmplay


1. 套用上公司庫存表格式，無法抓取所有綠字庫存
＿我這裡執行沒問題，是否office版本問題（我是２０００），這我無法解決
　
2. 非合併儲存格無法抓取，例如：「庫存」R37:S38非合併儲存格，R38就沒有抓到，因為「匯整」A76只抓到一個TEST
＿表格合併不規則，很難判斷，只能以〔數量〕為主，所以同一群組的數量，必須先〔合併〕

3. 是否可設定抓取資料範圍，因為只需抓取「庫存」A23:W122範圍資料，A23以上顏色資料無需抓取
＿程式已限制只匯入第２２列以下的資料

最好有其他大大用office 2010改一下程式！！我僅能做到這樣！

msmplay

回復 2# 准提部林

   准大~~~首先非常感謝幫忙喔!!但小妹測試後發現遇到問題已發問在附檔內，可以再麻煩你幫忙看一下原因嗎??真是不好意思耶~~~

Xl0000024.rar (20.79 KB)

下載次數: 3

2016-11-27 15:30

准提部林

〔項次．品牌．數量〕的文字顏色不一致，以〔數量〕為主：

1. Sub 匯入()
   
2. Dim R&, xArea As Range, xR As Range, xE(1 To 2) As Range, i%, C%, N%
   
3. With Sheets("匯整")
   
4.     .UsedRange.Offset(1, 0).EntireRow.Delete
   
5.      Set xE(1) = .[A2]: Set xE(2) = .[D2]
   
6. End With
   
7. 
   
8. With Sheets("庫存").UsedRange
   
9.      R = .Rows.Count - 22: If R <= 0 Then Exit Sub
   
10.      Set xArea = .Rows(23).Resize(R)
    
11. End With
    
12. 
    
13. For i = 3 To xArea.Columns.Count Step 4
    
14.     For Each xR In xArea.Columns(i).Cells
    
15.         N = 0: C = xR.Font.ColorIndex
    
16.         If C = 5 Then N = 1
    
17.         If C = 10 Then N = 2
    
18.         If xR = "" Or N = 0 Then GoTo 101
    
19.         R = xR.MergeArea.Rows.Count
    
20.         xR(1, 0).Resize(R, 2).Copy xE(N)
    
21.         Set xE(N) = xE(N)(R + 1)
    
22. 101: Next
    
23. Next i
    
24. End Sub

複製代碼

　
Xl0000024.rar (17.08 KB)

下載次數: 6

2016-11-27 13:37