Question

我正在使用Excel为结算系统生成报告，我想使用VBA来简化更新excel的过程。我想要做的是从Mastersheets中的列（“A：F”）复制，粘贴和附加信息，并根据各自命名工作表中的名称将它们分开。所有工作表从第4行开始。（第3行是标题）

所以我会进一步简化这个过程：从一个新的excelsheet开始，我想首先将主题表中的所有数据复制并粘贴到相应的命名工作表中。完成之后：

COPY，PASTE AND APPEND（在主板上进行更改时） 1.选择主表。 2.在主题表中，搜索现有工作表列（A）以获取帐单编号（以便仅允许将新帐单更新为现有数据） 3.将新的帐单编号从列（“A：F”）复制并粘贴到相应的命名工作表，从每个命名工作表的最后一个空行开始。（我想我已经在代码中定义了它，“George”表的一个问题，它没有贯穿整个工作表，它停在某个行号）

我现在的问题是我无法使追加功能起作用。复制和粘贴功能或多或少都可以完成。这是我到目前为止的代码。这就是我现在所做的一切。任何帮助将不胜感激。

' COPY, PASTE AND APPEND   
Sub Append()

Dim manager As String, lastrow As Long, i As Integer
Dim find As Range, bill As String


Set mastersheet = Sheet1

mastersheet.Select
bill = Sheet1.Range("A:A").Value
Do While Not bill = ""
Set find = Sheet1.Range("A:A").find(what:=bill, lookat:=xlValues, lookat:=xlWhole)
If find Is Nothing Then

lastrow = Cells(Rows.Count, 1).End(xlUp).row

For i = 2 To lastrow
If Cells(i, 2) = "JOHN" Then
    Range(Cells(i, 1), Cells(i, 6)).copy
    Sheet13.Select
    Range("A300").End(xlUp).Offset(1, 0).PasteSpecial
    mastersheet.Select

    End If

Next i
For i = 2 To lastrow
If Cells(i, 2) = "CHARLIE" Then
    Range(Cells(i, 1), Cells(i, 6)).copy
    Sheet11.Select
    Range("A300").End(xlUp).Offset(1, 0).PasteSpecial
    mastersheet.Select
    End If
Next i
For i = 2 To lastrow
If Cells(i, 2) = "GEORGE" Then
    Range(Cells(i, 1), Cells(i, 6)).copy
    Sheet12.Select
    Range("A300").End(xlUp).Offset(1, 0).PasteSpecial
    mastersheet.Select
    End If
Next i

Else

Sheet1.Select

End If
Loop

End Sub

Answer 1

我首先尝试清理代码（很多.select）。您没有定义.pastespecial在粘贴工作表上打印的内容。如果您只是粘贴，那么您可以缩短该行，只需将粘贴位置放在与复制位置相同的行，而不指定粘贴;它假设您只是从指定位置移动到新位置。

我相信从George的循环中更改和删除mastersheet.select，它可能有助于清理那张表。我不是说是这个问题，但是并没有这样做。另外，我给你更多定义的变量，因为没有保存值的问题（i到i，j和k）。

希望这些变化有助于阻碍！

' COPY, PASTE AND APPEND   
Sub Append()

Dim manager As String, lastrow As Long, i As Integer, k as integer, j as integer
Dim find As Range, bill As String

bill = Sheets("Sheet1").Range("A:A").Value
Do While Not bill = ""
Set find = Sheets("Sheet1").Range("A:A").find(what:=bill, lookat:=xlValues, lookat:=xlWhole)

If find Is Nothing Then

lastrow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).row

For i = 2 To lastrow
    If Cells(i, 2) = "JOHN" Then
    Range(Cells(i, 1), Cells(i, 6)).copy
    Sheets("Sheet13").Range("A300").End(xlUp).Offset(1, 0).PasteSpecial
    End If
Next i

For j = 2 To lastrow
    If Sheets("Sheet1").Cells(j, 2) = "CHARLIE" Then
    Sheets("Sheet1").Range(Cells(j, 1), Cells(j, 6)).copy
    Sheets("Sheet11").Range("A300").End(xlUp).Offset(1, 0).PasteSpecial
    End If
Next j

For k = 2 To lastrow
    If Sheets("Sheet1").Cells(k, 2) = "GEORGE" Then
    Sheets("Sheet1").Range(Cells(k, 1), Cells(k, 6)).copy
    Sheets("Sheet12").Range("A300").End(xlUp).Offset(1, 0).PasteSpecial
    End If
Next k

Else

Sheets("Sheet1").Select

End If
Loop

End Sub

VBA复制excel工作表，从特定列追加新行

1 个答案: