Question

我正在尝试编写一个宏，从一张纸上搜索数据并将其复制到另一张纸上。

但现在我遇到了问题，因为我想在两次搜索之间复制数据，并将多个单元格中的整个数据粘贴到一个单元格中。

例如在上图中我的宏：

搜索代表“--------------”和“***** END OF OF RECORD”
COPIES 介于两者之间的所有内容，此处是第29行和第30行以及A，B，C列的示例数据
PASTE 来自多个单元格A29，B29，C29，然后是A30，B30，C30到单张格子2中的单个单元格的所有数据称为单元格E2。
此模式在A列中重复发生，因此我想搜索下一个匹配项并执行所有步骤1,2,3，这次我将其粘贴到Sheet2，单元格E3中。

以下是代码：我能够搜索我的模式，但很难在这些搜索模式之间引用单元格，然后将所有数据复制到一个单元格。

 x = 2: y = 2: Z = 7000: m = 0: n = 0

Do
x = x + 1
If ThisWorkbook.Sheets("lic").Range("A" & x) = "---------------------" Then m = x
If ThisWorkbook.Sheets("lic").Range("A" & x) = "****** END OF RECORD" Then n = x
If (n > 0) Then

    Do
    For i = m To n
    ThisWorkbook.Sheets("lic").Range("A" & i + 1).Copy
    ThisWorkbook.Sheets("lic").Range("B" & i + 1).Copy
    ThisWorkbook.Sheets("lic").Range("C" & i + 1).Copy


'If (n > 0) Then ThisWorkbook.Sheets("Sheet1").Range("E" & y) = ThisWorkbook.Sheets("lic").Range("A" & m + 1, "C" & n - 1): y = y + 1
'If (n > 0) Then ThisWorkbook.Sheets("Sheet1").Range("E" & y).Resize(CopyFrom.Rows.Count).Value = CopyFrom.Value: y = y + 1
Loop While Not x > Z

'Driver's Licence #:Driver's Licence #:Driver's Licence #:

x = 2: y = 2: Z = 7000: counter = 1
Do
x = x + 1
If ThisWorkbook.Sheets("lic").Range("A" & x) = "Driver's Licence #:" Then counter = counter + 1
If (counter = 2) Then ThisWorkbook.Sheets("Sheet1").Range("B" & y) = ThisWorkbook.Sheets("lic").Range("C" & x): y = y + 1: counter = 0
If x = Z Then Exit Sub
Loop
End Sub

Answer 1

我完全不确定你想在最终输出中看到什么，所以这是一个有根据的猜测：

Sub DenseCopyPasteFill ()

  Dim wsFrom, wsTo As Worksheet
  Dim ur As Range
  Dim row, newRow As Integer
  Dim dataOn As Boolean
  Dim currentVal As String

  dataOn = False
  newRow = 3

  Set wsFrom = Sheets("Sheet1")
  Set wsTo = Sheets("Sheet2")
  Set ur = wsFrom.UsedRange

  For row = 1 To ur.Rows.Count
    If wsFrom.Cells(row, 1).Value2 = "--------------" Then
      dataOn = True
    ElseIf wsFrom.Cells(row, 1).Value2 = "***** END OF RECORD" Then
      newRow = newRow + 1
      dataOn = False
    ElseIf dataOn Then
      currentVal = wsTo.Cells(newRow, 5).Value2
      wsTo.Cells(newRow, 5).Value2 = currentVal & _
          wsFrom.Cells(row, 1) & wsFrom.Cells(row, 2) & _
          wsFrom.Cells(row, 3)
    End If

  Next row
End Sub

如果你可以在不使用Windows剪贴板的情况下离开，我会的。我没有复制/粘贴，而是演示了如何简单地添加或附加值。

Answer 2

添加此子：

Sub copy_range(rng As Range)
Dim str As String
str = rng.Cells(1).Value & rng.Cells(2).Value & rng.Cells(3).Value
Range("E" & Range("E" & Rows.Count).End(xlUp).Row + 1).Value = str
End Sub

那么你的for循环应该是这样的：

For i = m To n
    copy_range ThisWorkbook.Sheets("lic").Range("A" & i + 1 & ":C" & i + 1)
Next i

Answer 3

考虑到搜索工作正常，您需要做的是复制：

Sheet2.Range("E2").value = ThisWorkbook.Sheets("lic").Range("A" & i + 1).value & ";" & ThisWorkbook.Sheets("lic").Range("B" & i + 1).value & ";" & ThisWorkbook.Sheets("lic").Range("C" & i + 1).value

结果如下： AIR COO; L DAT; A 的

<强> -------- --------- UPDATE

很难理解你的代码，所以我写了一个新代码。基本上它将它在sheet1上找到的内容复制到sheet2。

Sub Copy()

Dim count As Integer 'Counter of loops to the for
Dim Z As Integer 'Limit of (?)
Dim h As Integer 'Count the filled cells on sheet2
Dim y As Integer 'Counter the columns to be copied

Z = 7000
h = 1


'Assuming that the "----" will always be on the top, the code will start searching on the second row
'if it's not true, will be needed to validate this to.
For count = 2 To Z

    If Sheet1.Cells(count, 1).Value <> "****** END OF RECORD" Then

        If Sheet1.Cells(count, 1).Value <> "" Then

            For y = 1 To 3 'In case you need to copy more columns just adjust this for.

                Sheet2.Cells(h, 1).Value = Sheet2.Cells(h, 1).Value & Sheet1.Cells(count, y).Value

            Next y

            h = h + 1

        End If

    Else

        MsgBox "END OF RECORD REACHED"
        Exit Sub

    End If

Next count

End Sub

也许我没有得到完整的想法，但这可能适合你。

在VBA宏中查找复制和粘贴

3 个答案: