Question

我正在尝试使用vba脚本将一些数据从一个工作表复制到另一个工作表，它工作正常但它似乎没有收集所有结果，我拥有的数据被分成多个表，所以我假设它是看到一片空白并走出去，但我不确定解决方案！（我之后的结果是所有字母，即A-f，都位于C列）

感谢下面的高级代码：

Sub copytoprint()
   Dim LSearchRow As Integer
   Dim LCopyToRow As Integer
   Application.ScreenUpdating = False
   On Error GoTo Err_Execute

   LSearchRow = 2
   LCopyToRow = 2

   While Len(Range("C" & CStr(LSearchRow)).value) > 0
     If InStr(1, Range("C" & CStr(LSearchRow)).value, "A") > 0 Then
         Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
         Selection.Copy

         Sheets("dest").Select
         Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
         ActiveSheet.Paste

         LCopyToRow = LCopyToRow + 1
         Sheets("source").Select

      End If

      LSearchRow = LSearchRow + 1

   Wend

   Application.CutCopyMode = False
   Range("A3").Select

   MsgBox "All matching data has been copied."

   Exit Sub

Err_Execute:
   MsgBox "An error occurred."

End Sub

输入只是一个基本的细节，即

ID      person  ref itemid  itemname        shape
Alphas1 bob     A   As01    Alphaselects1   circle
Alphas2 Stuart  B   As02    Alphaselects2   circle

基本上他们分成了许多记录，我希望它能抓住所有的A引用把它们放在一张表中，然后继续使用B C等

希望这有点意义吗？

Answer 1

因此，如果我正确理解您的问题，那么您需要先在工作表源中对数据进行排序，然后将所有这些数据粘贴到另一个工作表中。

如果是这种情况，请尝试使用此代码。

Sub copytoprint()

    Dim lastrow As Double

    With Sheets("source")
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("A2:F" & lastrow).Sort key1:=Range("C3:C" & lastrow), order1:=xlAscending, Header:=xlNo
    End With

    Sheets("dest").Range("A2:F" & lastrow).Value = Sheets("source").Range("A2:F" & lastrow).Value


End Sub

Answer 2

您希望使用特定参考（A，B，C等）从ActiveSheet进行搜索，并将匹配的行复制到唯一的目标工作表中。下面的代码将帮助您完成此任务，它将复制子过程分离到它自己的子（称为copyToSheet），并且您可以在每次提供所需的引用和目标表时从copytoprint（）继续调用它。

Option Explicit
Private Sub copyToSheet(reference As String, shtSource As Worksheet, shtDest As Worksheet)
    Dim x As Integer
    Dim y As Integer
    shtDest.Range("A2:Z" & shtDest.UsedRange.Rows.Count + 2).ClearContents
    x = 2
    y = 2
    'loop until 20 consequtive rows have column C blank
    While (Not shtSource.Range("C" & x).Value = "") _
        And (Not shtSource.Range("C" & (x + 1)).Value = "") _
        And (Not shtSource.Range("C" & (x + 5)).Value = "") _
        And (Not shtSource.Range("C" & (x + 10)).Value = "") _
        And (Not shtSource.Range("C" & (x + 20)).Value = "")

        'If shtSource.Range("C" & x).Value, reference) > 0 Then
        If shtSource.Range("C" & x).Value = reference Then
            shtDest.Range("A" & y & ":Z" & y).Value = shtSource.Range("A" & x & ":Z" & x).Value
            y = y + 1
        End If
        x = x + 1
    Wend
End Sub
Public Sub copytoprint()
    copyToSheet "A", ActiveSheet, Sheets("A")
    copyToSheet "B", ActiveSheet, Sheets("B")
    MsgBox "All matching data has been copied."
End Sub

Excel VBA复制多行

2 个答案: