Как я могу вставить в другую строку после получения результатов поиска

Question

Мне нужна помощь о том, как вставить результат в столбец "G" Строка "2" после поиска во всем столбце A слова "Код страны:". Ниже приведен мой код для процесса.

В настоящее время мой код может скопировать указанное c слово и вставить его. Но он вставляется только в столбец А, который перекрывает существующие данные.

 Sub SearchForString()

   Dim LSearchRow As Integer
   Dim LCopyToRow As Integer
   Dim LCopytoColumn As String


   'On Error GoTo Err_Execute

   'Start search in row 1
    LSearchRow = 1

   'Start copying data to column G in Database
    LCopytoColumn = 7

   'Start copying data to row 2 in Database and Loop results
    LCopyToRow = 2


   While Len(Range("A" & CStr(LSearchRow)).Value) > 0

          'If value in column E = "Mail Box", copy entire row to Sheet2
           If InStr(1, Range("A" & CStr(LSearchRow)).Value, "Country Code:") > 0 Then

         'Select row in Sheet1 to copy
          Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
          Selection.Copy

          'Paste row into G2 in next row
           Range("G2").Select
          'Columns(CStr(LCopytoColumn) & ":" & CStr(LCopytoColumn)).Select
           Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
           ActiveSheet.Paste


           'Move counter to next row
            LCopyToRow = LCopyToRow + 1

           'Go back to Database to continue searching
           Sheets("Database").Select

        End If

        LSearchRow = LSearchRow + 1

   Wend

   'Position on cell G2
    Application.CutCopyMode = False
    Range("G2").Select

    MsgBox "All matching data has been copied."

   Exit Sub

'Err_Execute:
'   MsgBox "An error occurred."

 End Sub

Answer 1

Использование Variant Array просто и быстро.

Sub test()
    Dim Ws As Worksheet
    Dim toWs As Worksheet
    Dim vDB, vR()
    Dim i As Long, n As Long, c As Integer
    Dim j As Integer

    Set Ws = Sheets("yoursheetname")
    Set toWs = Sheets("Database")

    vDB = Ws.UsedRange
    c = UBound(vDB, 2)
    For i = 1 To UBound(vDB, 1)
        If InStr(vDB(i, 1), "Country Code:") Then
            n = n + 1
            ReDim Preserve vR(1 To c, 1 To n)
            For j = 1 To c
                vR(j, n) = vDB(i, j)
            Next j
        End If
    Next i
    toWs.Range("g2").Resize(n, c) = WorksheetFunction.Transpose(vR)
End Sub