想要在宏中添加代码以将一行的公式粘贴到同一工作表上范围的底部。

huangapple go评论75阅读模式
英文:

VBA / Excel help: Want to add to a macro to paste formula from a row to the bottom of a range on the same sheet

问题

我有一个包含数据范围在B:C的Excel表格,从B30开始,延伸到一定数量的行。

在E1:O1中有一个公式。

我希望有一个可以点击的宏,它将复制E1:O1中的公式,并粘贴到B:C数据范围旁边(保留列D为空白)。

我一直在编辑来自这里的一些代码,它在大多数情况下都有效,但是当它从表的顶部复制公式时,它只将其粘贴到数据的顶行,而不是每一行。

以下是我编辑过的代码:

  1. 'move data data and populate formulas
  2. 'for New
  3. Sub Copy()
  4. Application.ScreenUpdating = False
  5. Dim s1 As Excel.Worksheet
  6. Dim s2 As Excel.Worksheet
  7. Dim s3 As Excel.Worksheet
  8. Dim s4 As Excel.Worksheet
  9. Dim iLastCellS2 As Excel.Range
  10. Dim iLastCellS3 As Excel.Range
  11. Dim iLastCellS4 As Excel.Range
  12. Dim idataRange1 As Excel.Range
  13. Dim idataRange2 As Excel.Range
  14. Dim idataRange3 As Excel.Range
  15. Dim iLastRowS1 As Long
  16. Set s1 = Sheets("SET UP")
  17. Set s2 = Sheets("New")
  18. Set s3 = Sheets("Current")
  19. Set s4 = Sheets("Proposed")
  20. '获取SET UP中列C的最后一行行号
  21. iLastRowS1 = s1.Cells(s1.Rows.Count, "C").End(xlUp).Row
  22. '获取要粘贴数据的New的最后一个可用单元格
  23. Set iLastCellS2 = s2.Cells(s2.Rows.Count, "B").End(xlUp).Offset(1, 0)
  24. '获取要粘贴数据的Current的最后一个可用单元格
  25. Set iLastCellS3 = s3.Cells(s3.Rows.Count, "B").End(xlUp).Offset(1, 0)
  26. '获取要粘贴数据的Proposed的最后一个可用单元格
  27. Set iLastCellS4 = s4.Cells(s4.Rows.Count, "B").End(xlUp).Offset(2, 0)
  28. '获取要粘贴公式的New的最后一个可用单元格
  29. Set idataRange1 = s2.Cells(s2.Rows.Count, "B").End(xlUp).Offset(1, 3)
  30. '获取要粘贴公式的Current的最后一个可用单元格
  31. Set idataRange2 = s3.Cells(s3.Rows.Count, "B").End(xlUp).Offset(1, 3)
  32. '获取要粘贴公式的Proposed的最后一个可用单元格
  33. Set idataRange3 = s4.Cells(s4.Rows.Count, "B").End(xlUp).Offset(2, 3)
  34. '复制并粘贴到New
  35. s1.Range("C17", s1.Cells(iLastRowS1, "D")).Copy iLastCellS2
  36. '复制并粘贴New的公式
  37. s2.Range("E1:O1").Copy idataRange1
  38. '复制并粘贴到Current
  39. s1.Range("C17", s1.Cells(iLastRowS1, "D")).Copy iLastCellS3
  40. '复制并粘贴Current的公式
  41. s3.Range("E1:O1").Copy idataRange2
  42. '复制并粘贴到Proposed
  43. s1.Range("C17", s1.Cells(iLastRowS1, "D")).Copy iLastCellS4
  44. '复制并粘贴Proposed的公式
  45. s4.Range("E1:AU1").Copy idataRange3
  46. Application.ScreenUpdating = True
  47. End Sub

我认为问题可能出在以下部分:s2.Range("E1:O1").Copy idataRange1s3.Range("E1:O1").Copy idataRange2,和s4.Range("E1:AU1").Copy idataRange3,这些代码只粘贴了公式到一个单元格。您可能需要修改这些行,以确保公式被粘贴到整个范围,而不仅仅是一个单元格。

英文:

I have an excel sheet with a range of data in B:C, starting at B30 that extends to a dynamic number of rows.

There is a forumla in E1:O1.

I wish to have a macro I can click that will copy the formula from E1:O1 and past it in the range next to the data in B:C (leaving colum d blank).

I have been editing some code from here and it works for the most part, however when it copys the formula from the top of the sheets it only pastes it in the top row of the data, not for every row.

Here is my edited code:

  1. 'move data data and populate formulas
  2. 'for New
  3. Sub Copy()
  4. Application.ScreenUpdating = False
  5. Dim s1 As Excel.Worksheet
  6. Dim s2 As Excel.Worksheet
  7. Dim s3 As Excel.Worksheet
  8. Dim s4 As Excel.Worksheet
  9. Dim iLastCellS2 As Excel.Range
  10. Dim iLastCellS3 As Excel.Range
  11. Dim iLastCellS4 As Excel.Range
  12. Dim idataRange1 As Excel.Range
  13. Dim idataRange2 As Excel.Range
  14. Dim idataRange3 As Excel.Range
  15. Dim iLastRowS1 As Long
  16. Set s1 = Sheets("SET UP")
  17. Set s2 = Sheets("New")
  18. Set s3 = Sheets("Current")
  19. Set s4 = Sheets("Proposed")
  20. ' get last row number of C in SET UP
  21. iLastRowS1 = s1.Cells(s1.Rows.Count, "C").End(xlUp).Row
  22. ' get last AVAILABLE cell to past into new for data data
  23. Set iLastCellS2 = s2.Cells(s2.Rows.Count, "B").End(xlUp).Offset(1, 0)
  24. ' get last AVAILABLE cell to past into current for data data
  25. Set iLastCellS3 = s3.Cells(s3.Rows.Count, "B").End(xlUp).Offset(1, 0)
  26. ' get last AVAILABLE cell to past into proposed for data data
  27. Set iLastCellS4 = s4.Cells(s4.Rows.Count, "B").End(xlUp).Offset(2, 0)
  28. ' get last AVAILABLE cell to past into new for formula
  29. Set idataRange1 = s2.Cells(s2.Rows.Count, "B").End(xlUp).Offset(1, 3)
  30. ' get last AVAILABLE cell to past into current for formula
  31. Set idataRange2 = s3.Cells(s3.Rows.Count, "B").End(xlUp).Offset(1, 3)
  32. ' get last AVAILABLE cell to past into proposed for formula
  33. Set idataRange3 = s4.Cells(s4.Rows.Count, "B").End(xlUp).Offset(2, 3)
  34. 'copy&paste into New
  35. s1.Range("C17", s1.Cells(iLastRowS1, "D")).Copy iLastCellS2
  36. 'copy&paste formulas for new
  37. s2.Range("E1:O1").Copy idataRange1
  38. 'copy&paste into Current
  39. s1.Range("C17", s1.Cells(iLastRowS1, "D")).Copy iLastCellS3
  40. 'copy&paste formulas for Current
  41. s3.Range("E1:O1").Copy idataRange2
  42. 'copy&paste into Proposed
  43. s1.Range("C17", s1.Cells(iLastRowS1, "D")).Copy iLastCellS4
  44. 'copy&paste formulas for proposed
  45. s4.Range("E1:AU1").Copy idataRange3
  46. Application.ScreenUpdating = True
  47. End Sub

I expect Im doing lots of this wrong - i am not experianced with Macros.

each section with the "'copy&paste formulas for " is only pasting into the top row, and not to the bottom of the range.

答案1

得分: 1

复制数据和公式

  1. Sub CopyDataAndFormulas()
  2. Const SRC_NAME As String = "SET UP"
  3. Const SRC_FIRST_CELL As String = "C17"
  4. Const SRC_COPY_COLUMNS As String = "C:D"
  5. Const DST_COLUMN As String = "B"
  6. Dim dwsNames(): dwsNames = VBA.Array("New", "Current", "Proposed")
  7. Dim dfAddresses(): dfAddresses = VBA.Array("E1:O1", "E1:O1", "E1:AU1")
  8. Dim wb As Workbook: Set wb = ThisWorkbook '包含此代码的工作簿
  9. Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
  10. Dim srg As Range, srCount As Long, scCount As Long
  11. With sws.Range(SRC_FIRST_CELL)
  12. srCount = sws.Cells(sws.Rows.Count, .Column).End(xlUp).Row - .Row + 1
  13. If srCount < 1 Then
  14. MsgBox "源工作表中没有数据。", vbCritical
  15. Exit Sub
  16. End If
  17. Set srg = .Resize(srCount).EntireRow.Columns(SRC_COPY_COLUMNS)
  18. scCount = srg.Columns.Count
  19. End With
  20. Application.ScreenUpdating = False
  21. Dim dws As Worksheet, drg As Range, dfCell As Range, n As Long
  22. For n = 0 To UBound(dwsNames)
  23. Set dws = wb.Sheets(dwsNames(n))
  24. Set dfCell = dws.Cells(dws.Rows.Count, DST_COLUMN).End(xlUp).Offset(1)
  25. Set drg = dfCell.Resize(srCount, scCount)
  26. srg.Copy drg
  27. ' 或者只复制数值:
  28. ' drg.Value = srg.Value
  29. With dws.Range(dfAddresses(n))
  30. .Copy Intersect(drg.EntireRow, .EntireColumn)
  31. End With
  32. Next n
  33. Application.ScreenUpdating = True
  34. MsgBox "数据和公式已复制。", vbInformation
  35. End Sub

想要在宏中添加代码以将一行的公式粘贴到同一工作表上范围的底部。

英文:

Copy Data and Formulas

想要在宏中添加代码以将一行的公式粘贴到同一工作表上范围的底部。

<!-- language: lang-vb -->

  1. Sub CopyDataAndFormulas()
  2. Const SRC_NAME As String = &quot;SET UP&quot;
  3. Const SRC_FIRST_CELL As String = &quot;C17&quot;
  4. Const SRC_COPY_COLUMNS As String = &quot;C:D&quot;
  5. Const DST_COLUMN As String = &quot;B&quot;
  6. Dim dwsNames(): dwsNames = VBA.Array(&quot;New&quot;, &quot;Current&quot;, &quot;Proposed&quot;)
  7. Dim dfAddresses(): dfAddresses = VBA.Array(&quot;E1:O1&quot;, &quot;E1:O1&quot;, &quot;E1:AU1&quot;)
  8. Dim wb As Workbook: Set wb = ThisWorkbook &#39; workbook containing this code
  9. Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
  10. Dim srg As Range, srCount As Long, scCount As Long
  11. With sws.Range(SRC_FIRST_CELL)
  12. srCount = sws.Cells(sws.Rows.Count, .Column).End(xlUp).Row - .Row + 1
  13. If srCount &lt; 1 Then
  14. MsgBox &quot;No data in source worksheet.&quot;, vbCritical
  15. Exit Sub
  16. End If
  17. Set srg = .Resize(srCount).EntireRow.Columns(SRC_COPY_COLUMNS)
  18. scCount = srg.Columns.Count
  19. End With
  20. Application.ScreenUpdating = False
  21. Dim dws As Worksheet, drg As Range, dfCell As Range, n As Long
  22. For n = 0 To UBound(dwsNames)
  23. Set dws = wb.Sheets(dwsNames(n))
  24. Set dfCell = dws.Cells(dws.Rows.Count, DST_COLUMN).End(xlUp).Offset(1)
  25. Set drg = dfCell.Resize(srCount, scCount)
  26. srg.Copy drg
  27. &#39; or to copy only values:
  28. &#39;drg.Value = srg.Value
  29. With dws.Range(dfAddresses(n))
  30. .Copy Intersect(drg.EntireRow, .EntireColumn)
  31. End With
  32. Next n
  33. Application.ScreenUpdating = True
  34. MsgBox &quot;Data and formulas copied.&quot;, vbInformation
  35. End Sub

答案2

得分: -1

s1.Range("E:O").Copy s2.Range("E:O")

英文:

Assuming you want to copy from s1 to s2:

  1. s1.Range(&quot;E:O&quot;).Copy s2.Range(&quot;E:O&quot;)

huangapple
  • 本文由 发表于 2023年7月10日 23:01:44
  • 转载请务必保留本文链接:https://go.coder-hub.com/76655028.html
匿名

发表评论

匿名网友

:?: :razz: :sad: :evil: :!: :smile: :oops: :grin: :eek: :shock: :???: :cool: :lol: :mad: :twisted: :roll: :wink: :idea: :arrow: :neutral: :cry: :mrgreen:

确定