Vba 复制并粘贴行N次(N次基于单元格中的值)
我读过很多类似的文章,但仍然不知道如何调整代码 我有一个代码,可以复制一个范围,并在“数据”选项卡中粘贴一次 我希望该范围根据工作表“NoOfRowsToPaste”单元格F12中的数值复制n次。我应该向代码中添加什么来执行此操作Vba 复制并粘贴行N次(N次基于单元格中的值),vba,excel,Vba,Excel,我读过很多类似的文章,但仍然不知道如何调整代码 我有一个代码,可以复制一个范围,并在“数据”选项卡中粘贴一次 我希望该范围根据工作表“NoOfRowsToPaste”单元格F12中的数值复制n次。我应该向代码中添加什么来执行此操作 Sub UpdateLogWorksheet() Dim historyWks As Worksheet Dim inputWks As Worksheet Dim nextRow As Long D
Sub UpdateLogWorksheet()
Dim historyWks As Worksheet
Dim inputWks As Worksheet
Dim nextRow As Long
Dim oCol As Long
Dim myCopy As Range
Dim myTest As Range
Dim lRsp As Long
Set inputWks = Worksheets("Input")
Set historyWks = Worksheets("Data")
oCol = 3 ' staff info is pasted on data sheet, starting in this column
'check for duplicate staff number in database
If inputWks.Range("CheckAssNo") = True Then
lRsp = MsgBox("Order ID already in database. Update record?", vbQuestion + vbYesNo, "Duplicate ID")
If lRsp = vbYes Then
UpdateLogRecord
Else
MsgBox "Please change Order ID to a unique number."
End If
Else
'cells to copy from Input sheet - some contain formulas
Set myCopy = inputWks.Range("Entry")
With historyWks
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
End With
With inputWks
'mandatory fields are tested in hidden column
Set myTest = myCopy.Offset(0, 2)
If Application.Count(myTest) > 0 Then
MsgBox "Please fill in all the cells!"
Exit Sub
End If
End With
With historyWks
'enter date and time stamp in record
With .Cells(nextRow, "A")
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
'enter user name in column B
.Cells(nextRow, "B").Value = Application.UserName
'copy the data and paste onto data sheet
myCopy.Copy
.Cells(nextRow, oCol).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
End With
'clear input cells that contain constants
ClearDataEntry
End If
End Sub
调整目标范围中的行数将正确复制复制的数据
n = Worksheets("NoOfRowsToPaste").Range("F12").Value
.Cells(nextRow, oCol).Resize(n).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Thomas给出了一个很好的答案,不过如果您想为不同的行执行额外的逻辑,我会实现一个循环并在中构建逻辑。以防万一
Sub UpdateLogWorksheet()
Dim historyWks As Worksheet
Dim inputWks As Worksheet
Dim nextRow As Long
Dim oCol As Long
Dim myCopy As Range
Dim myTest As Range
Dim lRsp As Long
Set inputWks = Worksheets("Input")
Set historyWks = Worksheets("Data")
Dim lng As Long
Dim pasteCount As Long
pasteCount = Worksheets("NoOfRowsToPaste").Cells(12, 6)
oCol = 3 ' staff info is pasted on data sheet, starting in this column
'check for duplicate staff number in database
If inputWks.Range("CheckAssNo") = True Then
lRsp = MsgBox("Order ID already in database. Update record?", vbQuestion + vbYesNo, "Duplicate ID")
If lRsp = vbYes Then
UpdateLogRecord
Else
MsgBox "Please change Order ID to a unique number."
End If
Else
'cells to copy from Input sheet - some contain formulas
Set myCopy = inputWks.Range("Entry")
With historyWks
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With inputWks
'mandatory fields are tested in hidden column
Set myTest = myCopy.Offset(0, 2)
If Application.Count(myTest) > 0 Then
MsgBox "Please fill in all the cells!"
Exit Sub
End If
End With
With historyWks
'enter date and time stamp in record
For lng = 1 To pasteCount
With .Cells(nextRow + lng, "A")
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
'enter user name in column B
.Cells(nextRow + lng, "B").Value = Application.UserName
'copy the data and paste onto data sheet
myCopy.Copy
.Cells(nextRow + lng, oCol).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Next lng
Application.CutCopyMode = False
End With
'clear input cells that contain constants
ClearDataEntry
End If
End Sub
嗨,泽克,非常感谢,当你说逻辑时,你说它是什么意思?当我复制X(例如12)行数时,我希望自定义一列。这意味着从活页“NoofroustOpaste”复制B14(包括B14)以上的X(例如12)个单元格。在这种情况下,您的代码是否工作得更好?两种方法都可以。托马斯的方法的优点是它短、干净、快速。我展示的循环方法以这种方式有更多的工作表事务,但是如果您愿意,您可以为每个单元格做额外的计算/派生值,并以不同的方式对待行。谢谢Zerk。我决定用你的,以防将来我需要做更复杂的事情。在这个问题之后,我将尝试找出后一个动作,如果我不能弄清楚自己,我将再次询问论坛:)