如何复制并粘贴最后一行直到特定日期?

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

How to copy and paste the last row until a certain date?

问题

I am fairly newer to VBA. 我对VBA相对较新。
I took a class in college and that has been years now since using it. 我在大学上了一门课,现在已经多年没有使用它了。
I am trying to copy the last row in a spreadsheet within columns A through S multiple times. 我尝试多次复制电子表格中从A列到S列的最后一行。
I am needing to do this from the date specified in the last cell in column A until the date I specify in cell A1. 我需要从列A中最后一个单元格中指定的日期开始,一直复制到我在A1单元格中指定的日期。
This is going to be a report I update weekly is why I am trying to do this. 这将是一个我每周更新的报告,这就是为什么我要这样做的原因。
I am needing to copy all of the formulas in the last row. 我需要复制最后一行中的所有公式。
I got this to work as a simple copy and paste. 我已经将这个工作做成了简单的复制和粘贴。
But once I did the if statement, it just does nothing with no error. 但是一旦我使用了if语句,它就什么都不做,没有错误。Any idea what I'm doing wrong? 有什么想法我做错了吗?

英文:

I am fairly newer to VBA. I took a class in college and that has been years now since using it. I am trying to copy the last row in a spreadsheet within columns A through S multiple times. I am needing to do this from the date specified in the last cell in column A until the date I specify in cell A1. This is going to be a report I update weekly is why I am trying to do this. I am needing to copy all of the formulas in the last row.

Public Sub CopyLastRow()
    
    ' Define the source sheet (no need to activate it)
    Dim sourceSheet As Worksheet
    Set sourceSheet = ThisWorkbook.Worksheets("Steam Data")
    
    ' Find the last row in an specific column
    Dim lastRow As Long
    lastRow = sourceSheet.Range("A" & sourceSheet.Rows.Count).End(xlUp).Row
    
    ' Set the source range according to columns and last row
    Dim sourceRange As Range
    Set sourceRange = sourceSheet.Range("A" & lastRow & ":S" & lastRow)
   
   Dim x As Integer
   Dim lcell As Long
   
   lcell = Cells(Rows.Count, 1).End(xlUp).Row

   For x = lcell To x = Range("A1")
   
   If x < Range("A1") Then
    sourceRange.Copy
    sourceRange.Offset(1).PasteSpecial
    Else
    
    End If
   
  Next x
End Sub

I got this to work as a simple copy and paste. But once I did the if statement, it just does nothing with no error. Any idea what I'm doing wrong?

答案1

得分: 1

如果我理解你最后的评论,下面的代码将完成你需要的任务。它可以放入一个模块或者"Steam Data"工作表的代码部分。不需要激活"Steam Data"工作表来运行这段代码:

Public Sub CopyLastRow()

  Dim ws             As Worksheet, _
      rngSourceRange As Range, _
      rngTargetRange As Range, _
      lngLastRow     As Long, _
      lngRowsToAdd   As Long, _
      dteTargetDate  As Date, _
      dteLastDate    As Date

  ' 定义我们要操作的工作表
  Set ws = ThisWorkbook.Worksheets("Steam Data")

  ' 确定目标日期
  ' 这将是你的“指定日期”,可以是单元格引用、传递给这个过程的参数,或者任何其他可能的来源。这里只是一个示例中硬编码的日期。
  dteTargetDate = #6/24/2023#

  With ws
    ' 确定列A中的最后一行
    lngLastRow = .Range("A" & .Rows.Count).End(xlUp).Row

    ' 确保我们找到了有效日期。如果没有,显示一条消息并退出。
    If IsDate(.Cells(lngLastRow, 1)) = False Then
      MsgBox "最后一行不包含有效日期。进程中止。"
      Exit Sub
    End If

    ' 计算我们需要添加的行数(天数)
    lngRowsToAdd = dteTargetDate - .Cells(lngLastRow, 1)

    ' 定义源和目标范围
    Set rngSourceRange = .Range("A" & lngLastRow)
    Set rngTargetRange = .Range("A" & lngLastRow & ":A" & lngLastRow + lngRowsToAdd)

    ' 使用“填充序列”选项将所选日期复制到目标范围
    rngSourceRange.AutoFill Destination:=rngTargetRange

    ' 选择并复制我们要重复的最后一行的列
    .Range("B" & lngLastRow & ":S" & lngLastRow).Copy

    ' 粘贴行
    .Paste Destination:=.Range("B" & lngLastRow + 1 & ":B" & lngLastRow + lngRowsToAdd)

  End With

  Set ws = Nothing

End Sub

有关更多信息,我不确定你是否熟悉开发者选项卡下的“录制宏”选项。这是一个非常有用的工具,可以基于你的按键生成基本的代码。生成的代码可能会有一些不必要的步骤,但可以进行清理。

英文:

If I understood your last comment, the code below will do what you need. It can go into a module or the code section of the "Steam Data" worksheet. The "Steam Data" worksheet does not need to be active to run the code:

Public Sub CopyLastRow()

  Dim ws             As Worksheet, _
      rngSourceRange As Range, _
      rngTargetRange As Range, _
      lngLastRow     As Long, _
      lngRowsToAdd   As Long, _
      dteTargetDate  As Date, _
      dteLastDate    As Date

  ' Define the sheet we want to work with
  Set ws = ThisWorkbook.Worksheets("Steam Data")

  ' Establish the target date
  ' This will be your 'specified date' and can be a cell reference, a parameter
  ' passed into this procedure, or any other possible source. I have just hardcoded
  ' a date here as an example.
  dteTargetDate = #6/24/2023#

  With ws
    ' Determine the last row in Column A
    lngLastRow = .Range("A" & .Rows.Count).End(xlUp).Row

    ' Make sure we have found a valid date. If not then show a message and get out.
    If IsDate(.Cells(lngLastRow, 1)) = False Then
      MsgBox "The last row does not contain a valid date. Process aborted."
      Exit Sub
    End If

    ' Calculate the number of rows (days) we need to add
    lngRowsToAdd = dteTargetDate - .Cells(lngLastRow, 1)

    ' Define the source and target ranges
    Set rngSourceRange = .Range("A" & lngLastRow)
    Set rngTargetRange = .Range("A" & lngLastRow & ":A" & lngLastRow + lngRowsToAdd)

    ' Copy the selected date to the target range with the 'Fill Series' option
    rngSourceRange.AutoFill Destination:=rngTargetRange

    ' Select and copy the columns from the last row that we want to repeat
    .Range("B" & lngLastRow & ":S" & lngLastRow).Copy

    ' Paste the rows
    .Paste Destination:=.Range("B" & lngLastRow + 1 & ":B" & lngLastRow + lngRowsToAdd)

  End With

  Set ws = Nothing

End Sub

For further info, I am not sure if you are familiar with the Record Macro option under the Developer Tab. This is a very useful tool for generating bare-bones code based on your keystrokes. The resulting code can be somewhat verbose with steps that may not be necessary but this can be cleaned up.

答案2

得分: 1

复制(追加)最后一行

快速修复(保留思路)

Sub CopyLastRowQF()

    ' 定义源工作表(无需激活)
    Dim sourceSheet As Worksheet
    Set sourceSheet = ThisWorkbook.Worksheets("Steam Data")
    
    ' 查找特定列中的最后一行
    Dim lastRow As Long
    lastRow = sourceSheet.Range("A" & sourceSheet.Rows.Count).End(xlUp).Row
    
    ' 根据列和最后一行设置源范围
    Dim sourceRange As Range
    Set sourceRange = sourceSheet.Range("A" & lastRow & ":S" & lastRow)
   
    Dim lCell As Range
    Set lCell = sourceRange.Cells(1)
    
    Dim destRange As Range
    Set destRange = sourceRange.Offset(1)
    
    Application.ScreenUpdating = False

    Dim x As Long
    
    For x = lCell.Value + 1 To sourceSheet.Range("A1").Value
        sourceRange.Copy destRange
        Set destRange = destRange.Offset(1)
    Next x

    Application.ScreenUpdating = True

End Sub

改进版本

Sub CopyLastRow()

    Const DATE_COLUMN As Long = 1
    
    With ThisWorkbook.Worksheets("Steam Data").Columns("A:S")
        Dim lCell As Range: Set lCell = .Columns(DATE_COLUMN) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Sub ' 列中没有数据
        Dim rCount As Long: rCount = .Cells(DATE_COLUMN).Value - lCell.Value
        If rCount < 1 Then
            MsgBox "行已经复制。", vbExclamation
            Exit Sub
        End If
        Dim srg As Range: Set srg = Intersect(lCell.EntireRow, .Cells)
        Dim drg As Range: Set drg = srg.Offset(1).Resize(rCount)
        srg.Copy drg
    End With

End Sub
英文:

Copy (Append) Last Row

如何复制并粘贴最后一行直到特定日期?

A Quick Fix (Preserving the Idea)

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

Sub CopyLastRowQF()
    
    &#39; Define the source sheet (no need to activate it)
    Dim sourceSheet As Worksheet
    Set sourceSheet = ThisWorkbook.Worksheets(&quot;Steam Data&quot;)
    
    &#39; Find the last row in a specific column
    Dim lastRow As Long
    lastRow = sourceSheet.Range(&quot;A&quot; &amp; sourceSheet.Rows.Count).End(xlUp).Row
    
    &#39; Set the source range according to columns and last row
    Dim sourceRange As Range
    Set sourceRange = sourceSheet.Range(&quot;A&quot; &amp; lastRow &amp; &quot;:S&quot; &amp; lastRow)
   
    Dim lCell As Range
    Set lCell = sourceRange.Cells(1)
    
    Dim destRange As Range
    Set destRange = sourceRange.Offset(1)
    
    Application.ScreenUpdating = False

    Dim x As Long
    
    For x = lCell.Value + 1 To sourceSheet.Range(&quot;A1&quot;).Value
        sourceRange.Copy destRange
        Set destRange = destRange.Offset(1)
    Next x

    Application.ScreenUpdating = True

End Sub

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

An Improvement

Sub CopyLastRow()
    
    Const DATE_COLUMN As Long = 1
    
    With ThisWorkbook.Worksheets(&quot;Steam Data&quot;).Columns(&quot;A:S&quot;)
        Dim lCell As Range: Set lCell = .Columns(DATE_COLUMN) _
            .Find(&quot;*&quot;, , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Sub &#39; no data in column
        Dim rCount As Long: rCount = .Cells(DATE_COLUMN).Value - lCell.Value
        If rCount &lt; 1 Then
            MsgBox &quot;Rows already copied.&quot;, vbExclamation
            Exit Sub
        End If
        Dim srg As Range: Set srg = Intersect(lCell.EntireRow, .Cells)
        Dim drg As Range: Set drg = srg.Offset(1).Resize(rCount)
        srg.Copy drg
    End With

End Sub

答案3

得分: 0

以下是翻译好的代码部分:

最后部分的代码需要进行调整,移除不正确构造的 `For ... Next` 循环以及 `If ... Else ... End If`。请参考我的代码片段:

Dim x As Integer
Dim lcell As Long

lcell = Cells(Rows.Count, 1).End(xlUp).Row

' For x = lcell To 14 'x = Range("A1")

' If x < Range("A1") Then
sourceRange.Copy
sourceRange.Offset(1).PasteSpecial
' Else

' End If

' Next x

请注意,我已经按照您的要求只返回了翻译好的部分。

英文:

The last part of your code needs to be adjusted by removing the For ... Next loop (which is improperly constructed to begin with) and removing the If ... Else ... End If. See my code snippet below:

   Dim x As Integer
   Dim lcell As Long
   
   lcell = Cells(Rows.Count, 1).End(xlUp).Row

&#39;   For x = lcell To 14   &#39;x = Range(&quot;A1&quot;)
   
&#39;   If x &lt; Range(&quot;A1&quot;) Then
    sourceRange.Copy
    sourceRange.Offset(1).PasteSpecial
&#39;    Else
    
&#39;    End If
   
&#39;  Next x

huangapple
  • 本文由 发表于 2023年6月30日 02:57:44
  • 转载请务必保留本文链接:https://go.coder-hub.com/76583920.html
匿名

发表评论

匿名网友

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

确定