Board logo

標題: [發問] 自動開啟指定的檔案和標示底色。 [打印本頁]
作者: ziv976688    時間: 2019-8-26 01:43     標題: 自動開啟指定的檔案和標示底色。

本帖最後由 ziv976688 於 2019-8-26 01:50 編輯

測試檔案 :  [attach]31180[/attach]

請問 :下列需求的正確語法 ?
需求 :
1_自動開啟指定名稱的檔案~ EX :  "539_五行排序-??總覽-(####-##-##).xls"

2_將指定名稱的檔案開啟後，再將Sheet1和Sheet2的下列範圍標示15號底色      
        Range("BA3:BF12").Interior.ColorIndex = 15
        Range("BA15:BF24").Interior.ColorIndex = 15
        Range("BA27:BF36").Interior.ColorIndex = 15
        Range("BA39:BF48").Interior.ColorIndex = 15
        Range("BA51:BF60").Interior.ColorIndex = 15
        Range("BA63:BF72").Interior.ColorIndex = 15
        Range("BA75:BF84").Interior.ColorIndex = 15
3_將完成第2項需求的檔案關閉。      


以上 誠請各位大大幫忙! 謝謝各位!
作者: s13030029    時間: 2019-8-26 15:47

回復 1# ziv976688
大概是這樣吧~~
  1. Sub 自動填色_Click()
  2.     Application.ScreenUpdating = False
  3.    
  4.     Dim databook As Workbook
  5.     Path = ThisWorkbook.Path '檔案路徑
  6.     Filename = Sheets(1).Range("A1").Value '指定名稱
  7.     Set databook = Workbooks.Open(Path & "\" & Filename) '開啟檔案
  8.     With databook.Sheets(1)
  9.         .Range("BA3:BF12").Interior.ColorIndex = 15
  10.         .Range("BA15:BF24").Interior.ColorIndex = 15
  11.         .Range("BA27:BF36").Interior.ColorIndex = 15
  12.         .Range("BA39:BF48").Interior.ColorIndex = 15
  13.         .Range("BA51:BF60").Interior.ColorIndex = 15
  14.         .Range("BA63:BF72").Interior.ColorIndex = 15
  15.         .Range("BA75:BF84").Interior.ColorIndex = 15
  16.     End With
  17.     With databook.Sheets(2)
  18.         .Range("BA3:BF12").Interior.ColorIndex = 15
  19.         .Range("BA15:BF24").Interior.ColorIndex = 15
  20.         .Range("BA27:BF36").Interior.ColorIndex = 15
  21.         .Range("BA39:BF48").Interior.ColorIndex = 15
  22.         .Range("BA51:BF60").Interior.ColorIndex = 15
  23.         .Range("BA63:BF72").Interior.ColorIndex = 15
  24.         .Range("BA75:BF84").Interior.ColorIndex = 15
  25.     End With
  26.     databook.Save  '儲存
  27.     databook.Close  '關閉
  28.     Application.ScreenUpdating = True
  29. End Sub
複製代碼
作者: ziv976688    時間: 2019-8-27 07:50

回復 2# s13030029
感謝回覆。
測試結果:只有標示1個檔案，不是每一個檔案都有標示。
作者: s13030029    時間: 2019-8-27 08:24

回復 3# ziv976688
我只指定"A1"儲存格為檔名
因為我不知道你要從哪裡設定你要變更檔案的檔名
作者: s13030029    時間: 2019-8-27 09:10

回復 3# ziv976688
加個迴圈吧
  1. Sub 自動填色_Click()
  2.     Application.ScreenUpdating = False
  3.    
  4.     Dim databook As Workbook
  5.     Path = ThisWorkbook.Path '檔案路徑
  6.    
  7.     For i = 1 To Sheets(1).Range("A300").End(xlUp).Row
  8.     Filename = Cells(i, "A").Value '檔名
  9.     Set databook = Workbooks.Open(Path & "\" & Filename) '開啟檔案
  10.     With databook.Sheets(1)
  11.         .Range("BA3:BF12").Interior.ColorIndex = 15
  12.         .Range("BA15:BF24").Interior.ColorIndex = 15
  13.         .Range("BA27:BF36").Interior.ColorIndex = 15
  14.         .Range("BA39:BF48").Interior.ColorIndex = 15
  15.         .Range("BA51:BF60").Interior.ColorIndex = 15
  16.         .Range("BA63:BF72").Interior.ColorIndex = 15
  17.         .Range("BA75:BF84").Interior.ColorIndex = 15
  18.     End With
  19.     With databook.Sheets(2)
  20.         .Range("BA3:BF12").Interior.ColorIndex = 15
  21.         .Range("BA15:BF24").Interior.ColorIndex = 15
  22.         .Range("BA27:BF36").Interior.ColorIndex = 15
  23.         .Range("BA39:BF48").Interior.ColorIndex = 15
  24.         .Range("BA51:BF60").Interior.ColorIndex = 15
  25.         .Range("BA63:BF72").Interior.ColorIndex = 15
  26.         .Range("BA75:BF84").Interior.ColorIndex = 15
  27.     End With
  28.     databook.Save  '儲存
  29.     databook.Close  '關閉
  30.     Next
  31.    
  32.     Application.ScreenUpdating = True
  33. End Sub
複製代碼
作者: ziv976688    時間: 2019-8-27 22:05

回復 5# s13030029
謝謝您的再次指教~可以了^^
作者: 准提部林    時間: 2019-8-28 10:17

Sub TEST()
Dim P$, F$, xD, A, Tm, ADR$, xB As Workbook, xS As Worksheet
Tm = Timer
P = ThisWorkbook.Path
Set xD = CreateObject("Scripting.Dictionary")
Do
  If F = "" Then F = Dir(P & "\*.xls") Else F = Dir()
  If F = "" Then Exit Do
  If F Like "539_五行排序-??總覽-(####-##-##).xls" Then xD(F) = ""
Loop
If xD.Count = 0 Then Exit Sub
Application.ScreenUpdating = False
ADR = "BA3:BF12,BA15:BF24,BA27:BF36,BA39:BF48,BA51:BF60,BA63:BF72,BA75:BF84"
For Each A In xD.keys
    Set xB = Workbooks.Open(P & "\" & A)
    For Each xS In xB.Sheets
        xS.Range(ADR).Interior.ColorIndex = 15
    Next
    xB.Close 1
Next
MsgBox Timer - Tm
End Sub


==================================
作者: ziv976688    時間: 2019-8-28 16:24

本帖最後由 ziv976688 於 2019-8-28 16:29 編輯

回復 7# 准提部林
感謝版主的指教。
原提問的程式碼也是擷取您的程式碼^^"
完全符合需求~再次感謝您^^



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