Question

首先，通过一些搜索和一些Google-Fu。我将一个有效的Excel电子表格与一些VBA拼凑在一起。我绝不是一个程序员，也不是我的职业，但是，这是我对它的基本理解。那就是说，我一直在撞墙撞墙。

我将数据从网站提取到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步：现在使用每列（A - N）中的公式将信息复制到sheet3中：

=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

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

1 个答案: