返回列表 上一主題 發帖

複製儲存格顏色問題

an13755

帖子
20 
主題
7 
精華
0 
積分
50 
點名
0  
作業系統
xp 
軟體版本
2003 
閱讀權限
20 
性別
女 
註冊時間
2010-7-16 
最後登錄
2022-5-27 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2011-9-20 21:33 | 只看該作者

複製儲存格顏色問題

請各位大師幫忙

工作表A到工作表E中黃色儲存格

皆為藉由設定化格式條件而變成黃色儲存格

今想複製工作表A儲存格a1:a100的數字及顏色

轉置貼在工作表總表b2:cw2上

複製工作表B儲存格a1:a100的數字及顏色

轉置貼在工作表總表b3:cw3上

以此類推至工作表E

附檔為已完成的範例請參考謝謝!! Book1.rar (7.84 KB)
收藏 分享
an

oobird
　頭銜: 街友一族

超級版主Rank: 8Rank: 8

帖子
1572 
主題
16 
精華
2 
積分
1521 
點名
0  
作業系統
xp 
軟體版本
office 2003 
閱讀權限
150 
性別
男 
註冊時間
2010-5-1 
最後登錄
2016-1-13 

論壇貢獻勳章
2#
發表於 2011-9-20 22:14 | 只看該作者
  1. Sub test()
  2. For i = 1 To 5
  3. Set c = Sheets(i).[a1:a100]
  4. For Each k In c
  5. If Not Sheets(i).[d1:k1].Find(k, , , 1) Is Nothing Then
  6. k.Interior.ColorIndex = 6
  7. End If
  8. Next
  9. c.Copy
  10. Sheets("總表").Cells(i + 1, 2).PasteSpecial Transpose:=True
  11. Application.CutCopyMode = False
  12. Next
  13. End Sub
複製代碼

TOP

an13755

帖子
20 
主題
7 
精華
0 
積分
50 
點名
0  
作業系統
xp 
軟體版本
2003 
閱讀權限
20 
性別
女 
註冊時間
2010-7-16 
最後登錄
2022-5-27 
3#
發表於 2011-9-20 23:45 | 只看該作者
非常感謝o大師的幫忙,程式很好用,幫了小女子1個大忙

小女子不材還請大師再幫1個忙,因想把這個程式插進其他程式之中

能不能不用迴圈的方式寫的程式,因為在其他的檔案中,工作表總表名稱順序數量皆不1樣

小女子功力不足,請大師幫忙,謝謝!!
an

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
4#
發表於 2011-9-21 08:09 | 只看該作者
回復 3# an13755
  1. Sub Ex()
  2.     Dim 總表 As String, Sh As Worksheet, E As Range, i As Integer
  3.     With ActiveWorkbook
  4.         總表 = InputBox("輸入總表名稱", , .ActiveSheet.Name)
  5.         If 總表 = "" Then Exit Sub
  6.         On Error GoTo A:
  7.         .Sheets(總表).Activate
  8.         For Each Sh In .Sheets
  9.             If Sh.Name <> 總表 Then
  10.                 For Each E In Sh.[a1:a100]
  11.                     If Not Sh.[d1:k1].Find(E, , , 1) Is Nothing Then
  12.                         E.Interior.ColorIndex = 6
  13.                     End If
  14.                 Next
  15.                 Sh.[a1:a100].Copy
  16.                 ActiveWorkbook.Sheets(總表).Cells(i + 2, 2).PasteSpecial Transpose:=True
  17.                 i = i + 1
  18.             End If
  19.         Next
  20.     End With
  21.     Application.CutCopyMode = False
  22. A:
  23.     If Err.Number > 0 Then
  24.         MsgBox "總表 名稱錯誤"
  25.     Else
  26.         MsgBox "工作 完成 !!"
  27.     End If
  28. End Sub
複製代碼

TOP

an13755

帖子
20 
主題
7 
精華
0 
積分
50 
點名
0  
作業系統
xp 
軟體版本
2003 
閱讀權限
20 
性別
女 
註冊時間
2010-7-16 
最後登錄
2022-5-27 
5#
發表於 2011-9-22 18:14 | 只看該作者
感謝G大師的幫助,謝謝!!
an

TOP

        靜思自在 : 有願放在心裡，沒有身體力行，正如耕田不播種，皆是空過因緣。
返回列表 上一主題