如何复制一定范围的单元格，一次只能复制一个，并且总是复制到最后一行？

Question

我第一次来这个网站。 我有一个工作表，我输入数据，最后单击命令按钮，我将该数据表从该工作表转移到另外两个工作表中，其中一个正在工作，因为它将进入单元格，然后偏移其他数据点。

它将另一个复制到下一个可用的单元格，但是如果范围内有多个单元格，它将遍历它而不是转到下一个单元格。 因此，请查看Adddata2并告诉我我在做错什么，如果我只有一个数据条目有效，但是如果我有多个数据条目，它将删除添加的第一个数据条目并放入新的数据条目，如果有一个空白细胞它做同样的事情。 我正在寻找SortCmt！

谢谢

Private Sub cmdAjouter5S_Click()
On Error GoTo ERAJOUT
Dim AddDATA As Range


Dim AddDATA2 As Range
Dim MSG, STYLE, TITLE, RESPONSE
Dim Éliminer, Ranger, Nettoyer, Standard, Respect As Variant
Dim SortCmt1, SortCmt2, SortCmt3, SortCmt4, SortCmt5 As String
Dim SetCmt1, SetCmt2, SetCmt3, SetCmt4, SetCmt5 As String
Dim ShineCmt1, ShineCmt2, ShineCmt3, ShineCmt4, ShineCmt5 As String
Dim StandCmt1, StandCmt2, StandCmt3, StandCmt4, StandCmt5 As String
Dim SusCmt1, SusCmt2, SusCmt3, SusCmt4, SusCmt5 As String
Dim AddDate As Date
Dim OPCL As String
Dim RNG As Range

'Définition des variables afin de prendre et d'envoyer les donnée au bon endroit
Set AddDATA = Sheet2.Cells(Rows.Count, 22).End(xlUp).Offset(1, 0)
Set AddDATA2 = Sheet63.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
Set RNG = Sheet63.Range("B2:B500")
SortCmt1 = Range("B27").Value
SortCmt2 = Range("B28").Value
SortCmt3 = Range("B29").Value
SortCmt4 = Range("B30").Value
SortCmt5 = Range("B31").Value

'Définition des variables de données
Éliminer = Range("E9").Value
Ranger = Range("G9").Value
Nettoyer = Range("I9").Value
Standard = Range("K9").Value
Respect = Range("M9").Value
AddDate = Sheet1.DTPicker1.Value
Verificateur = Range("D4").Value
OPCL = "Open"

MSG = "Êtes-vous sûr de vouloir ajouter les données?" & vbCrLf & vbCrLf & _
"Vous ne pourrez les modifiées par la suite, donc assurez-vous que celles-ci sont exactes!"
STYLE = vbYesNo + vbCritical + vbDefaultButton2
TITLE = "IMPORTANT MESSAGE"
RESPONSE = MsgBox(MSG, STYLE, TITLE)

If Range("P9").Value = 0 Or Range("D4").Value = 0 Or Range("P9").Value = "Error" Then GoTo EAJOUT
If RESPONSE = vbYes Then
  AddDATA.Value = AddDate
  AddDATA.Offset(0, 2).Value = Éliminer
  AddDATA.Offset(0, 3).Value = Ranger
  AddDATA.Offset(0, 4).Value = Nettoyer
  AddDATA.Offset(0, 5).Value = Standard
  AddDATA.Offset(0, 6).Value = Respect
  AddDATA.Offset(0, 11).Value = Verificateur
  AddDATA2.Value = SortCmt1
  AddDATA2.Value = SortCmt2
  AddDATA2.Value = SortCmt3
  AddDATA2.Value = SortCmt4
  AddDATA2.Value = SortCmt5

  MsgBox "Vos données ont été ajoutez!" & vbCrLf & "Merci", vbInformation, "Équipe 5S!"

Else
  MsgBox "Vérifiez et recommencez au besoin", vbInformation, "VÉRIFICATION"
  GoTo AJOUT
End If

Range("B27:B31").Value = ""
Range("B42:B46").Value = ""
Range("B57:B61").Value = ""
Range("B72:B76").Value = ""
Range("B87:B91").Value = ""
Range("S20:S24").Value = ""
Range("S35:S39").Value = ""
Range("S50:S54").Value = ""
Range("S65:S69").Value = ""
Range("S80:S84").Value = ""
Range("D4").Value = ""

For Each cell In RNG
  If cell.Value <> "" And IsEmpty(cell.Offset(0, 3).Value) = True Then
    cell.Offset(0, 3).Value = OPCL
  End If
Next

GoTo AJOUT
EAJOUT:
MsgBox "Vous n'avez pas entrées de donnée! Retournez entrer vos données."

AJOUT:
Exit Sub

ERAJOUT:
MsgBox Err.Description
MsgBox "Une erreur c'est produite voir avec Martin SVP"
Resume EAJOUT

End Sub

Answer 1

这是因为：

AddDATA2.Value = SortCmt1
AddDATA2.Value = SortCmt2
AddDATA2.Value = SortCmt3
AddDATA2.Value = SortCmt4
AddDATA2.Value = SortCmt5

您覆盖5倍于单元格AddDATA2的值

如果您想将Sheet63.Range（“ B27：B31”）值向下写入从AddDATA2单元格开始的一列，则可以这样编写：

AddDATA2.Resize(5).Value = Sheet63.Range("B27:B31").Value

或者，如果您希望此值从AddDATA2沿行向右复制：

AddDATA2.Resize(,5).Value = Application.Transpose(Sheet63.Range("B27:B31").Value)