准提部林

回復 20# Qin


Sub CopyPaste()
Dim xA As Range, xB As Workbook, xS As Worksheet, Chk%
Set xA = ActiveSheet.UsedRange
Application.ScreenUpdating = False
Set xB = Workbooks.Open(ThisWorkbook.Path & "\bcca.xls", Password:="1234")
For Each xS In xB.Sheets
    If Left(xS.Name, 6) = "w_PRG_" Then Chk = 1: Exit For
Next
If Chk = 0 Then MsgBox "工作表〔w_PRG〕不存在！　": Exit Sub
With xS
    .Unprotect "pass"
    .UsedRange.Clear
     xA.Copy .[A1]
     .UsedRange.Font.Color = vbWhite
     .Name = "w_PRG_" & Format(Date, "yyyymmdd")
     .Protect "pass"
End With
xB.Close 1
MsgBox "複製完成！　"
End Sub

Qin

回復 21# 准提部林

准大
以上的問題解決了, 實在是太棒了,它簡化了我工作的流程. 感激!!

不好意思, 還有一點小問題
之前沒注意到...

1) 想將 L ,M 單元格的資料 copy 去 A & B 欄里,
為何C , F & G 的資料就抓不出來了??

2) 有時會因為手誤, 誤刪A欄的資料, 為何不能用" Ctrl Z" Undo 重新叫出來?

    bcca2.rar (43.29 KB)

下載次數: 9

2018-11-25 18:32

准提部林

回復 22# Qin

１）要去了解每一行程式碼的意思, 不然問一堆會沒完沒了～～～～
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xR As Range, xF As Range, xCr, xCf, j%
xCr = Array(3, 6, 7)
xCf = Array(2, 4, 5)
With Target.Columns(1)  '貼入或輸入區的第一欄
     If .Column <> 1 Then Exit Sub
     For Each xR In .Cells
         If .Row = 1 Then GoTo 101
         xR(1, 3).Resize(1, 5).ClearContents
         If xR = "" Then GoTo 101
         Set xF = Sheet1.[A:A].Find(xR, LookAt:=xlWhole, MatchCase:=False)
         If xF Is Nothing Then GoTo 101
         For j = 0 To UBound(xCr)
             xR(1, xCr(j)) = xF(1, xCf(j)).Value
         Next j
101: Next
End With
End Sub
　
２）CHANGE觸發的程式，就無法再使用〔復原〕！
　
　
　

Qin

回復 23# 准提部林

好的, 在努力學習中....

Qin

回復 23# 准提部林


想起尚未回覆准大的問題

CHANGE觸發的程式，就無法再使用〔復原〕

不了, 還是讓它保留原狀

謝謝!!


   








終于想起步驟的"驟"字了..