'Сочетание клавиш: Ctrl+z
lLastRow = Cells.SpecialCells(xlLastCell).Row
diapazon = Range("G2:P" & lLastRow) 'диапазон, где ищутся коды из ЧЗ.
'Первая ячейка и последний столбец
For r = 2 To UBound(diapazon) '2-начальная строка поиска
        For c = 7 To 15 ' 7 и 15 начальный и конецный столбец поиска
        'определение ячейки с гиперссылкой
            If Get_Hyperlink_Address(Cells(r, c)) <> "" Then
            'если ячейка найдена, поместить результат в первую свободную
            'строку столбца 6
            lLastRowA = Cells(Rows.Count, 6).End(xlUp).Row
            Cells(lLastRowA + 1, 6) = Cells(r, c)
        End If
        'перебор c и r до конца диапазона
    Next c
Next r

Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    Range("A:A").Select
    Selection.Replace What:="0", Replacement:=""

Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValues

.........
Selection.Copy
ChDir "C:\"Папка" 'путь к папке с нужным файлом
Workbooks.Open Filename:="Имя.xlsx" ' имя файла в этой папке
Range("A1").Select
ActiveSheet.Paste
Range("A1").Select' снова сделать активной только А1
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub

Sub Макрос1()
'
' Макрос1 Макрос
'
' Сочетание клавиш: Ctrl+m
'
    Range("A1").Select
    Selection.Copy
    ChDir "C:\Users\user\Documents" 'путь к папке с нужным файлом
Workbooks.Open Filename:="Книга2.xlsx" ' имя файла в этой папке
    Range("A1").Select
    ActiveSheet.Paste
    ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub

lLastRowA = Cells(Rows.Count, 5).End(xlUp).Row
            Cells(lLastRowA + 1, 5) = Cells(r, c)

Sub test()
Dim i&, iCnt1&, iCnt2&, arr()
For i = 1 To 100
    If UCase(Cells(i, 1).Value) Like UCase("яблоко") Then iCnt1 = iCnt1 + 1
Next i
MsgBox "На листе " & iCnt1 & "  яблок."
End Sub