Question

我需要复制一个范围（Sheet2 B2：S2），将其粘贴到第7行后第一个空行上的同一张纸上，将相同的数据粘贴到Sheet1上的第一个空行，然后清除原始内容范围（Sheet2 B2：S2）为下一个条目做好准备。

我曾试图使用其他帖子，但我无法弄清楚该怎么做。

这是执行简单位的宏

 Sub Macro2()
'
' Macro2 Macro
'

'
    Sheets("Sheet2").Select
    Range("B2:S2").Select
    Selection.Copy
    Range("B7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Sheet1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Sheet2").Select
    Range("B2:S2").Select
    Application.CutCopyMode = False
    Selection.ClearContents
End Sub

粘贴在最后一行。我需要它来粘贴时找到下一个免费线。

Answer 1

试试这个，通过删除你的select语句来整理：

Sub Macro2()
Dim SourceRange, TargetRange1, TargetRange2 As Range
Dim RowToPaste As Long
   'set range of source data
   Set SourceRange = Sheets("Sheet2").Range("B2:S2")
   'cater for chance that less than 7 rows are populated - we want to paste from row 8 as a minimum
   If (Sheets("Sheet2").Range("B" & Rows.Count).End(xlUp).Row + 1) < 8 Then
      RowToPaste = 8
   Else
      'Add 1 to the value of the last populated row
      RowToPaste = Sheets("Sheet2").Range("B" & Rows.Count).End(xlUp).Row + 1
   End If
   'Set the address of the target 1 range based on the last populated row in column B
   Set TargetRange1 = Sheets("Sheet2").Range("B" & RowToPaste)
   'Copy Source to target 1
   SourceRange.Copy Destination:=TargetRange1
   'Cater for Sheet 1 being totally empty and set target row to 1
   If Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row = 1 And _
    Len(Sheets("Sheet1").Range("A1")) = 0 Then
      RowToPaste = 1
   Else 'set target row to last populated row + 1
      RowToPaste = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
   End If
   'Set the target 2 range based on the last empty row in column A
   Set TargetRange2 = Sheets("Sheet1").Range("A" & RowToPaste)
   'Paste the source to target 2
   SourceRange.Copy Destination:=TargetRange2
   'Clear the source data
   SourceRange.ClearContents
End Sub

Answer 2

你真是太近了！问题是您永远不会增加目标range对象 - 它始终设置为Range("B7")。以下经过深思熟虑的代码应该能够实现您的目标：

Option Explicit
Public Sub MoveRowFrom2To1()

Dim shtSource As Worksheet, shtResult As Worksheet
Dim rngSource As Range, rngResult As Range
Dim lngLastRowOnSheet1 As Long, lngLastRowOnSheet2 As Long

'Set references up-front
Set shtSource = ThisWorkbook.Worksheets("Sheet2")
Set shtResult = ThisWorkbook.Worksheets("Sheet1")

'Identify the last occupied row on Sheet1 and Sheet2
lngLastRowOnSheet1 = LastRowNum(shtResult)
lngLastRowOnSheet2 = LastRowNum(shtSource)

'If the last occupied row is < 7, default to 6 so it writes to 7
If lngLastRowOnSheet2 < 7 Then
    lngLastRowOnSheet2 = 6
End If

'Identify the Source data and Sheet2 Destination
Set rngSource = shtSource.Range("B2:S2")
Set rngResult = shtSource.Cells(lngLastRowOnSheet2 + 1, 2) '<~ column 2 is B

'Copy the Source data from Sheet2 to lower on Sheet2
rngSource.Copy
rngResult.PasteSpecial (xlPasteValues)

'Identify the Sheet1 Destination
Set rngResult = shtResult.Cells(lngLastRowOnSheet1 + 1, 2) '<~ column 2 is B

'Paste the Source data from Sheet2 onto Sheet1
rngResult.PasteSpecial (xlPasteValues)

'Clear the Source range in anticipation of a new entry
rngSource.ClearContents

End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT       : Sheet, the worksheet we'll search to find the last row
'OUTPUT      : Long, the last occupied row
'SPECIAL CASE: if Sheet is empty, return 0
Public Function LastRowNum(Sheet As Worksheet) As Long
    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
        LastRowNum = Sheet.Cells.Find(What:="*", _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious).Row
    Else
        LastRowNum = 0
    End If
End Function

将范围复制到另一个工作表中的下一个自由行

2 个答案: