- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
6#
發表於 2019-5-10 14:10
| 只看該作者
回復 5# cslu37
依你附檔內容所寫程式碼
試試看- Option Explicit
- Dim Rng As Range
- Sub Ex_下拉1()
- Dim i As Integer, AR(), E As Variant
- AR = Array(工作表2, 工作表3)
- '***子程式的方呆措施*****
- For Each E In AR '迴圈 e : 依序傳回 陣列內的工作表物件
- If TypeName(E) <> "Worksheet" Then MsgBox "陣列元素需是 Worksheet 物件": End
- Next
- '*************************
- With Sheets("工作表1")
- Set Rng = .Range("a3", "e" & .Range("a2").End(xlDown).Row)
- If .Range("a2").End(xlDown).Row = Rows.Count Then
- Set Rng = .Range("A3") '工作表1尚未有資料
- Rng = Date
- For i = 2 To 5 '迴圈:依序輸入資料
- '**不知公式為和**
- Rng.Cells(1, i) = i
- Next
- Else
- '工作表1已有資料 , 用範圍下拉方法
- If Rng.Rows.Count = 1 Then ''**因下拉的範圍列數只有一列***
- .Select
- Rng.Cells(2, 1).Activate
- MsgBox "下拉的範圍列數只有一列" & vbLf & "請自行輸入" & Rng.Offset(1).Address & "的數值...."
- End
-
- End If
- Rng.AutoFill Destination:=Rng.Rows("1:" & Rng.Rows.Count + 1), Type:=xlFillDefault
- Set Rng = Rng.Cells(Rng.Rows.Count + 1, 1) 'A欄範圍內最後的日期
- End If
- End With
- Ex_下拉2 AR '呼叫 子程序
- End Sub
- Sub Ex_下拉2(Sh As Variant) '子程序 需傳遞參數(陣列(工作表物件))
- Dim xRng As Range, AR(), E As Variant
- For Each E In Sh '迴圈 e : 依序傳回 陣列內的工作表物件
- If E.Name = "工作表2" Then
- '資料2-3 資料2-4 資料2-5 資料2-6 的公式
- AR = Array("=rc[-2]*1+rC[-1]*1", "=rC[-3]*rC[-2]+rC[-1]", "=rC[-3]*rC[-2]-rc[-1]", "=rc[-3]+rc[-2]-rc[-1]")
- ElseIf E.Name = "工作表3" Then
- '資料3-3 資料3-4 資料3-5 資料3-6 資料3-7 資料3-8 '的公式
- AR = Array("=rc[-2]+rc[-1]", "=rc[-1]-rc[-2]", "=rc[-2]+rc[-1]", "=rc[-2]*rc[-1]", "=rc[-2]+rc[-1]", "=rc[-2]-rc[-1]")
- Else
- MsgBox "工作表錯誤 程式關閉": End
- End If
- Set xRng = E.Range("A:A").Find(Rng.Text, LookIn:=xlValues) '尋找工作表1A欄範圍內最後的日期
- If xRng Is Nothing Then '沒找到
- Set xRng = E.Range("A" & Rows.Count).End(xlUp).Offset(1)
- '設為A欄範圍內最後的日期的下一列位
- Else
- If xRng.Range("A2") <> "" Then '找到 且 下一列位<>""
- With xRng
- Range(.Cells(2, 1), .Range("A2").End(xlToRight).End(xlDown)) = ""
- '清除下一列位後的資料
- End With
- End If
- End If
- xRng.Resize(, 3).Value = Rng.Resize(, 3).Value '給上工作表下拉A:C的資料
- With xRng.Cells(1, 4).Resize(, UBound(AR) + 1)
- .Cells = AR '給上工作表2,工作表3:C後資料的公式
- '***** 如上列 給上工作表2,工作表3:C後資料的公式 正確
- .Cells = .Value '***** 可用下列此程式碼將處存格的公式轉為值
- '*************************************************
- End With
- Next
- End Sub
|
|
發表於 2019-5-2 18:39
| 
