返回列表 上一主題 發帖

[發問] 請問「最後一行資料 下拉複製」到新的一行,如何寫成巨集或VB呢?

回復 1# cslu37
試試看
這工作表 Sheet模組 的程式碼
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Rng As Range
  4.     Set Rng = Range("A2:E2")
  5.     If Rng.End(xlDown).Row <> Rows.Count Then
  6.         '工作表的總列數: Rows.Count 2003=65536,2010=1048576
  7.         Set Rng = Range(Rng, Rng.End(xlDown))
  8.         '"A2:E2" 往下延伸到最後又資料的位置
  9.     End If
  10.     'Range.AutoFill 方法 可參說明
  11.     With Rng
  12.         .AutoFill Destination:=.Rows("1:" & .Rows.Count + 1), Type:=xlFillDefault
  13.         '.Rows("1:" & .Rows.Count + 1)  Rng的列數+1的範圍
  14.     End With
  15.    
  16. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 5# cslu37

依你附檔內容所寫程式碼
試試看
  1. Option Explicit
  2. Dim Rng As Range
  3. Sub Ex_下拉1()
  4.     Dim i As Integer, AR(), E As Variant
  5.     AR = Array(工作表2, 工作表3)
  6.     '***子程式的方呆措施*****
  7.     For Each E In AR  '迴圈 e : 依序傳回 陣列內的工作表物件
  8.         If TypeName(E) <> "Worksheet" Then MsgBox "陣列元素需是   Worksheet 物件": End
  9.     Next
  10.     '*************************
  11.     With Sheets("工作表1")
  12.         Set Rng = .Range("a3", "e" & .Range("a2").End(xlDown).Row)
  13.         If .Range("a2").End(xlDown).Row = Rows.Count Then
  14.             Set Rng = .Range("A3")   '工作表1尚未有資料
  15.             Rng = Date
  16.             For i = 2 To 5  '迴圈:依序輸入資料
  17.                 '**不知公式為和**
  18.                 Rng.Cells(1, i) = i
  19.             Next
  20.         Else
  21.             '工作表1已有資料 , 用範圍下拉方法
  22.             If Rng.Rows.Count = 1 Then ''**因下拉的範圍列數只有一列***
  23.                 .Select
  24.                 Rng.Cells(2, 1).Activate
  25.                 MsgBox "下拉的範圍列數只有一列" & vbLf & "請自行輸入" & Rng.Offset(1).Address & "的數值...."
  26.                 End
  27.                
  28.             End If
  29.             Rng.AutoFill Destination:=Rng.Rows("1:" & Rng.Rows.Count + 1), Type:=xlFillDefault
  30.             Set Rng = Rng.Cells(Rng.Rows.Count + 1, 1) 'A欄範圍內最後的日期
  31.         End If
  32.     End With
  33.     Ex_下拉2 AR  '呼叫 子程序
  34. End Sub
  35. Sub Ex_下拉2(Sh As Variant)  '子程序 需傳遞參數(陣列(工作表物件))
  36.     Dim xRng As Range, AR(), E As Variant
  37.     For Each E In Sh  '迴圈 e : 依序傳回 陣列內的工作表物件
  38.         If E.Name = "工作表2" Then
  39.             '資料2-3 資料2-4 資料2-5 資料2-6 的公式
  40.             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]")
  41.         ElseIf E.Name = "工作表3" Then
  42.             '資料3-3 資料3-4 資料3-5 資料3-6 資料3-7 資料3-8  '的公式
  43.             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]")
  44.         Else
  45.             MsgBox "工作表錯誤 程式關閉": End
  46.         End If
  47.         Set xRng = E.Range("A:A").Find(Rng.Text, LookIn:=xlValues) '尋找工作表1A欄範圍內最後的日期
  48.         If xRng Is Nothing Then   '沒找到
  49.             Set xRng = E.Range("A" & Rows.Count).End(xlUp).Offset(1)
  50.             '設為A欄範圍內最後的日期的下一列位
  51.         Else
  52.             If xRng.Range("A2") <> "" Then  '找到 且 下一列位<>""
  53.                 With xRng
  54.                     Range(.Cells(2, 1), .Range("A2").End(xlToRight).End(xlDown)) = ""
  55.                     '清除下一列位後的資料
  56.                 End With
  57.             End If
  58.         End If
  59.         xRng.Resize(, 3).Value = Rng.Resize(, 3).Value  '給上工作表下拉A:C的資料
  60.         With xRng.Cells(1, 4).Resize(, UBound(AR) + 1)
  61.             .Cells = AR '給上工作表2,工作表3:C後資料的公式
  62.             '***** 如上列 給上工作表2,工作表3:C後資料的公式 正確
  63.            .Cells = .Value '***** 可用下列此程式碼將處存格的公式轉為值
  64.          '*************************************************
  65.         End With
  66.     Next
  67. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 【行善要及時】行善要及時,功德要持續。如燒開水一般,未燒開之前千萬不要停熄火候,否則重來就太費事了。
返回列表 上一主題