複製範圍到另一個工作表，並從輸入框中插入名稱與此副本

Question

我有我有命令按鈕和輸入文本框的用戶窗體。

我想從一張工作表中複製指定範圍，然後命名並粘貼到另一張工作表中。 我的代碼看起來像這樣，但它不起作用。

Private Sub CommandButton1_Click() 
Dim i, LastRow 
Dim ws As Worksheet 
Dim k As Integer 
Set ws = Worksheets("Vali") 
LastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row 
For i = 4 To LastRow 'find fulfiled rows 
If Sheets("Sheet1").Cells(i, "D").Value = 1 Then 
Sheets("Sheet1").Range(Cells(i, "B"), Cells(i, "D")).Copy Destination:=Sheets("Vali").Range("A" & Rows.Count).End(xlUp).Offset(1) 
End If 
Next i 
Dim i As Integer 
'Next we use a looping process 'We start the loop from row 2 because our worksheet has headers in row 1 
For k = 2 To 100 
'Now we define a condition that only if there is data under the headers ItemID, Description, 
If Cells(k, "A").Value <> "" And Cells(k, "B").Value <> "" And Cells(k, "C").Value <> "" And Cells(k, "D").Value <> "" And Cells(k, "E").Value = "" Then 
Cells(k, "D").Value = Me.txtname.Value 
End If 
Next 
Range("E:E").EntireColumn.AutoFit 
Range("B4:D21").ClearContents 'clear content on previos sheet, from where we made copy 
ActiveWorkbook.Save 
ValiFinish.Hide 
End Sub 

Answer 1

不知道你是想用你的測試做你第二個循環，因爲沒有紙基準的，所以我選擇，讓我知道這是不是

Private Sub CommandButton1_Click() 
    Application.ScreenUpdating = False 
    Dim LastRow As Double 
    Dim ws As Worksheet 
    Dim Wv As Worksheet 
    Dim k As Integer 
    Dim i As Integer 
    Dim Ti() 
    ReDim Ti(0) 
    Dim StartPaste As Double 
    Dim EndPaste As Double 
    Dim PastedRange As String 

    Set ws = Worksheets("Sheet1") 
    Set Wv = Worksheets("Vali") 

LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row 
StartPaste = Wv.Range("A" & Rows.Count).End(xlUp).Offset(1).Row 

For i = 2 To LastRow 
    If ws.Cells(i, "D").Value = 1 Then 

     ws.Range(ws.Cells(i, "A"), ws.Cells(i, "D")).Copy _ 
      Destination:=Wv.Range("A" & Rows.Count).End(xlUp).Offset(1) 
     Ti(UBound(Ti)) = i 
     ReDim Preserve Ti(UBound(Ti) + i) 
     EndPaste = Wv.Range("A" & Rows.Count).End(xlUp).Offset(1).Row - 1 

     '2 options because i'm not sur where you want to add the text : 
     'First one (write on Vali, I think that's what you are looking to do) : 
     If Wv.Cells(EndPaste, "A").Value <> "" And Wv.Cells(EndPaste, "B").Value <> "" And Wv.Cells(EndPaste, "C").Value <> "" _ 
      And Wv.Cells(EndPaste, "D").Value <> "" And Wv.Cells(EndPaste, "E").Value = "" Then 
       Wv.Cells(Wv.Range("A" & Rows.Count).End(xlUp).Row, "E").Value = ValiFinish.TxTNaMe.Value 
     End If 
     'Second one (write on Sheet1) : 
     If ws.Cells(i, "A").Value <> "" And ws.Cells(i, "B").Value <> "" And ws.Cells(i, "C").Value <> "" _ 
      And ws.Cells(i, "D").Value <> "" And ws.Cells(i, "E").Value = "" Then 
       ws.Cells(ws.Range("A" & Rows.Count).End(xlUp).Row, "E").Value = ValiFinish.TxTNaMe.Value 
     End If 
     'end of options 
    End If 
Next i 

PastedRange = "" & Wv.Name & "!R" & StartPaste & "C1:R" & EndPaste & "C3" 
ActiveWorkbook.Names.Add Name:=ValiFinish.TxTNaMe.Value, RefersToR1C1:=PastedRange 




'clear content on previous sheet, from where we made copy 
For i = LBound(Ti) To UBound(Ti) - 1 
    ws.Range("$B$" & Ti(i) & ":$D$" & Ti(i)).ClearContents 
Next i 


    Wv.Range("E:E").EntireColumn.AutoFit 
    Set ws = Nothing 
    Set Wv = Nothing 

    ActiveWorkbook.Save 
    ValiFinish.Hide 
    Application.ScreenUpdating = True 

End Sub