在 VBA 宏中查找复制和粘贴

Question

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

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

例如上图中我的宏：

1. 搜索“--------------”和“*****END OF RECORD”
2. COPIES 介于两者之间的所有内容，此处为第 29 行和第 30 行以及 A、B、C 列中的示例数据

3. 粘贴将多个单元格 A29、B29、C29 和 A30、B30、C30 中的所有数据粘贴到表 2 中的单个单元格中，例如单元格 E2。

4. 此模式在 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

考虑到搜索正常，关于复制的事情你只需要做：

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;大号数据；一个

--------更新---------

很难理解你的代码，所以我正在写一个新的。基本上是将在 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

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

Answer 2

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

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 3

添加这个子：

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