[發問] 救救我吧！日期複製（詳情請參閱內文）

emmalee

步驟一：當使用者在b1輸入開始日期(不定期)
步驟二：到sheet1中搜尋到b1日期後選取開始日到最終日期today()=>黃色底，並複製
步驟三：把sheet1黃色底複製到sheet2的a3
請問巨集要怎麼做???????:'(

Hsieh

回復 1# emmalee
SHEET1工作表模組

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. If Target.Address <> "$B$1" Then Exit Sub
   
3. With Sheet2
   
4. Set a = .Columns("A").Find(Target, LookIn:=xlValues)
   
5. Set b = .Columns("A").Find(Date, LookIn:=xlValues)
   
6. If Not a Is Nothing And Not b Is Nothing Then
   
7. Range([A3], Cells(Rows.Count, 2)) = ""
   
8. .Range(a, b.Offset(, 1)).Copy [A3]
   
9. End If
   
10. End With
    
11. End Sub

複製代碼

luhpro

回復 1# emmalee
以下程式放在 Sheet2 內

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.   Dim iRow%
   
3.   
   
4.   With Target
   
5.     If .Column = 2 And .Row = 1 Then
   
6.       Application.EnableEvents = False
   
7.       With .Parent
   
8.         iRow = .Cells(Rows.Count, 1).End(xlUp).Row
   
9.         If iRow < 3 Then iRow = 3
   
10.         .Range(.[A3], .Cells(iRow, 2)).Clear
    
11.       End With
    
12.       Call GetDate(Target)
    
13.       Application.EnableEvents = True
    
14.       Target.Select
    
15.       
    
16.     End If
    
17.   End With
    
18. End Sub

複製代碼

以下程式放在 Module 內

1. Sub GetDate(ByVal rTar As Range)
   
2.   Dim iRow%
   
3.   Dim dDate As Date
   
4.   Dim vSheet1, rFind As Range
   
5.   
   
6.   On Error Resume Next
   
7.   Set vSheet1 = Sheets("Sheet1")
   
8.   
   
9.   With vSheet1
   
10.     iRow = .Cells(Rows.Count, 1).End(xlUp).Row
    
11.     Set rFind = Nothing
    
12.     dDate = rTar.Value
    
13.     Do Until rFind.Row > 1
    
14.       Set rFind = Range(.[A2], .Cells(iRow, 1)).Find(dDate, LookIn:=xlValues)
    
15.       dDate = dDate + 1
    
16.     Loop
    
17.       .Range(rFind, .Cells(iRow, 2)).Copy
    
18.       rTar.Parent.[A3].PasteSpecial Paste:=xlPasteAll
    
19.   End With
    
20. End Sub

複製代碼

emmalee

不好意思，不太懂，是不是貼到巨集就可以用了?
不好意思，是兩個都貼到巨集裡面嗎?但是我無法使用??
另外可以詳解給我聽嗎?謝謝?

Hsieh

回復 4# emmalee


   

下載 (631.87 KB)

2011-6-9 23:59