将填充单元格中的值仅复制到不同的工作表，而不会在最后一次填充的值后添加额外的行

Question

首先，稍微搜索一下Google-Fu。我用一些VBA将Excel电子表格拼凑在一起。我绝不是一个编码员，也不是我的专业，但是，这是我基本了解的。也就是说，我一直把头撞在墙上。

我正在将数据从网站拖入Excel中的sheet1中，将其复制到sheet2，同时清理了一下数据，再次将其复制到sheet3以进一步隔离我需要的信息。 （我知道这是一个过于复杂的过程，但通过逐步完成，我对所发生的事情有了更好的理解，这有助于我学习）。

第一步，复制挖掘网站的数据到Sheet2中：

Sub DataReOrganizer() 
    Dim s1 As Worksheet, s2 As Worksheet 
    Dim Cook As Long, i As Long, K As Long, v As String 
    On Error Resume Next 
    Set s1 = Sheets("Sheet1") 
    Set s2 = Sheets("Sheet2") 
    Cook = s1.Cells(Rows.Count, "A").End(xlUp).Row 
    K = 2 

    For i = 1 To Cook 
     v = s1.Cells(i, "A").Text 
     If v = "Contact Information" Then 
     K = K + 1 
     Else 
     ary = Split(v, ": ") 
     If ary(0) = "Name" Then s2.Cells(K, 1) = ary(1) 
     If ary(0) = "License" Then s2.Cells(K, 2) = ary(1) 
     If ary(0) = "License Status" Then s2.Cells(K, 3) = ary(1) 
     If ary(0) = "City/State" Then s2.Cells(K, 4) = ary(1) 
     If ary(0) = "County" Then s2.Cells(K, 5) = ary(1) 
     If ary(0) = "Home Phone" Then s2.Cells(K, 6) = ary(1) 
     If ary(0) = "Work Phone" Then s2.Cells(K, 7) = ary(1) 
     If ary(0) = "Cell Phone" Then s2.Cells(K, 8) = ary(1) 
     If ary(0) = "Email Address" Then s2.Cells(K, 9) = ary(1) 
     If ary(0) = "Region" Then s2.Cells(K, 10) = ary(1) 
     If ary(0) = "Ever Been Disciplined?" Then s2.Cells(K, 11) = ary(1) 
     If ary(0) = "Note" Then s2.Cells(K, 12) = ary(1) 
     End If 
    Next I 
End Sub 

现在的信息是A列中不再是一个大的总质量，我将转到步骤2：现在，该信息复制到使用表Sheet 3在每列式（A - N）例如：

=IFERROR(SUBSTITUTE(LEFT(Sheet2!$A2,SEARCH(", ",Sheet2!$A2)),",",""),"") 

的公式去每列行1500，这样做是为了保持在Sheet3的网站总是组织拉数据的变化量。我可能只有600行左右的数据，而其余的单元格，最多1500个，都是空白的。

这是我卡住的地方。我可以将这些值（减去公式）复制到sheet4。但是，它会复制填充值以及公式中没有计算值的单元格的900行左右。我搜索并找到了各种代码来删除空单元格，但它们不工作，或者我无法弄清楚如何调整它们以供我使用。无论我使用什么代码复制，它总是返回1500行，只有600个左右填充。我错过了什么吗？我甚至试图仅用值来复制新创建的工作表，该工作表仍然返回1500行。

***编辑补充我目前使用的代码用于测试目的：

Sub Test_Copy() 
    Worksheets("Sheet3").Range("A:N").Copy 
    Worksheets("Sheet4").Range("A:N").PasteSpecial Paste:=xlPasteValues 
    Application.CutCopyMode = False 
End Sub 

我发现了另一个问题，有一些代码，拷贝每个细胞，一次一个，但这是非常缓慢的。
Excel macro - paste only non empty cells from one sheet to another

另外，我从反应中得到印象，这不是一个好主意或最佳实践。

Answer 1

编辑和固定

Sub test() 

    Dim LastRow As Long 

    For y = LastColumnInOneRow To 1 Step -1 
     LastRow = Sheets("Sheet3").cells(Sheets("Sheet3").Rows.Count, y).End(xlUp).row 
     For x = LastRow To 1 Step -1 
      Sheets("Sheet4").cells(x, y).value = Sheets("Sheet3").cells(x, y).value 
     Next x 
    Next y 

End Sub 

Private Function LastColumnInOneRow() As Long 

    With Sheets("Sheet4") 
     LastColumnInOneRow = .cells(1, .Columns.Count).End(xlToLeft).column 
    End With 

End Function