Sub copy()
Application.ScreenUpdating = False

Dim rCell As Range, rRange As Range, rTable As Long, name As String
With CreateObject("Scripting.Dictionary")
      Set rRange = Sheets("новое кп").UsedRange
          For Each rCell In rRange
              If rCell.Value = "Дата:" Then
                  .Add Key:="дата", Item:=rCell.Offset(0, 1).Value
              End If
                
              If rCell.Value = "Номер:" Then
                  .Add Key:="Номер", Item:=rCell.Offset(0, 1).Value
              End If
              If rCell.Value = "Наименование Оборудования" Then ' тут задайте свои параметры, так как я не совсем понял,
                  .Add Key:="Наименование Оборудования", Item:=rCell.Value ' что именно нужно копировать
              End If
              If rCell.Value = "ИТОГО С НДС:" Then
                  .Add Key:="Итого", Item:=rCell.Offset(0, 2).Value
              End If
              If rCell.Value = "Коммерческое предложение для" Then
                  .Add Key:="Покупатель", Item:=rCell.Offset(0, 1).Value
              End If
              If rCell.Value = "для:" Then
                  .Add Key:="Пользователь", Item:=rCell.Offset(0, 1).Value
              End If
              If rCell.Value = "г. " Then
                  .Add Key:="Город", Item:=rCell.Offset(0, 1).Value
              End If
              If rCell.Value = "контактное лицо:" Then
                  .Add Key:="Контакт", Item:=rCell.Offset(0, 1).Value
              End If
              If rCell.Value = "тел:" Then
                  .Add Key:="Телефон", Item:=rCell.Offset(0, 1).Value
              End If
              If rCell.Value = "Дата:" Then
                  .Add Key:="Дата", Item:=rCell.Offset(0, 1).Value
              End If
              If rCell.Value = "e-mail: " Then
                  .Add Key:="E-mail", Item:=rCell.Offset(0, 1).Value
              End If
           Next

      For i = 1 To Sheets.Count
          If Sheets(i).name = .Item("Номер") Then
              MsgBox "Такой номер КП уже сохраняли": Exit Sub
          End If
      Next
rTable = Sheets("таблица").UsedRange.Rows.Count + 1

Sheets("таблица").Cells(rTable, 1).Formula = .Item("Дата")
Sheets("таблица").Cells(rTable, 2).Formula = .Item("Номер")

name = .Item("Номер")
Sheets("таблица").Hyperlinks.Add Anchor:=Sheets("таблица").Cells(rTable, 2), Address:="", SubAddress:= _
          "'" + name + "'" + "!A1", TextToDisplay:=name

Sheets("таблица").Cells(rTable, 3).Formula = .Item("Наименование Оборудования")
Sheets("таблица").Cells(rTable, 4).Formula = .Item("Итого")
Sheets("таблица").Cells(rTable, 5).Formula = .Item("Покупатель")
Sheets("таблица").Cells(rTable, 6).Formula = .Item("Пользователь")
Sheets("таблица").Cells(rTable, 7).Formula = .Item("Город")
Sheets("таблица").Cells(rTable, 8).Formula = .Item("Контакт")
Sheets("таблица").Cells(rTable, 9).Formula = .Item("Телефон")
Sheets("таблица").Cells(rTable, 10).Formula = .Item("E-mail")

Sheets("Новое кп").copy After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).UsedRange.Value = Sheets(Sheets.Count).UsedRange.Value
Sheets(Sheets.Count).Shapes.Range(Array("Rounded Rectangle 1")).Delete
Sheets(Sheets.Count).name = .Item("Номер")
Sheets("Новое кп").Activate

End With

MsgBox "Saved"
Application.ScreenUpdating = True

End Sub