Nhờ anh/chị hướng dẫn gắn hyperlink (2 người xem)

[sagowinmkt]

Dạ em cần gắn toàn bộ link ở cột bên trái sang hyperlink ở cột bên phải. Có cách nào gắn nhanh toàn bộ cột trái sang cột phải không ạ.

 

[vu_tuan_manh_linh]

Quét cột trái, Copy Paste Special Hyplink sang cột phải. Bạn thử xem thế nào!! Tôi chưa thử chưa biết có được không!!

 

[huhumalu]

Dạ em cần gắn toàn bộ link ở cột bên trái sang hyperlink ở cột bên phải. Có cách nào gắn nhanh toàn bộ cột trái sang cột phải không ạ.

Bạn xem thử dùng công thức =HYPERLINK(B2,C2)

 

[ptm0412]

Quét cột trái, Copy Paste Special Hyplink sang cột phải. Bạn thử xem thế nào!! Tôi chưa thử chưa biết có được không!!

Thử rồi, và không có.

 

[vu_tuan_manh_linh]

Thử rồi, và không có.

Cảm ơn bác!! Tự dưng thấy câu trả lời của em cảm tính và thiếu trách nhiệm quá!!!

 

[cantl]

..., office 2021 em mới cài lại giờ phát hiện ra mất tính năng copy link web dán vào là tự động link và được tô màu xanh luôn. Trước thì dán ầm ầm mà giờ thì đen sì. Ôi các tính năng mất dần mất mòn luôn.
Paste special cũng ít hơn.

 

[ptm0412]

Đù, office 2021 em mới cài lại giờ phát hiện ra mất tính năng copy link web

Chữ đầu tiên trong câu có phải là bạn dùng rất thường xuyên trong nhà, tại công ty, với vợ, con, anh em, bao gồm cả người nhỏ và người lớn không?

 

[cantl]

Chữ đầu tiên trong câu có phải là bạn dùng rất thường xuyên trong nhà, tại công ty, với vợ, con, anh em, bao gồm cả người nhỏ và người lớn không?

Không bác, ít dùng lắm bác, có khi phải mấy tháng mới dùng 1 lần. Dạo này em hay xem cờ tướng online, mấy thằng cùng xem cứ chửi loạn cả lên làm em cũng chửi theo.

Em đã xoá rồi, hề hề.

 

[ptm0412]

Em đã xoá rồi, hề hề.

Đâu có phải viết bài chửi thề lung tung rồi cười hề hề cho qua chuyện như vậy? Nếu như tôi không nhìn thấy thì cứ thế mà chửi tràn diễn đàn à?

 

[HeSanbi]

@sagowinmkt Sử dụng Hàm UDF VBA Hyperlink2 dưới đây bạn chỉ cần nhập một biểu thức duy nhất vào 1 ô. Là bạn có thể tạo Link cho dữ liệu.

Ví dụ: Nhập Cột Link, Cột chuỗi hiển thị, Cột típ.​

=Hyperlink2(A1:A1000,B1,C1)​

Ví dụ: Nhập Cột Link, Cột chuỗi hiển thị​

=Hyperlink2(A1:A1000,B1)​

Ví dụ: Nhập Cột Link​

=Hyperlink2(A1:A1000)​

Chép mã dưới vào một module mới và lưu tệp dạng xlsm hoặc xlsb

'                    _,
' ___   _   _  _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'

Private Const ProjectUDFName = "UDFHyperlink"
Private Const ProjectUDFFileName = "UDFHyperlink"
Private Const ProjectUDFVersion = "1.00"

Option Explicit
Option Compare Text

#If VBA7 = 0 Then
  Private Enum LongLong:[_]:End Enum
  Private Enum LongPtr:[_]:End Enum
#End If
#If Win64 Then
  Private Const PTR_LEN = 8&
#Else
  Private Const PTR_LEN = 4&
#End If
Private Const NULL_PTR As LongPtr = 0
Private Type POINTAPI
    x As Long
    y As Long
End Type
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Enum UDFDynamicDirection
  ffsFXMain = 1
  ffsAddFX

End Enum

Private Enum VBProceduleCaller
  VPCCell = 1
  VPCObject
  VPCEvaluate
  VPCCall
End Enum
Private Type UDFDynamicParameters
  direction As Long
  navigate As Long
  caller As VBProceduleCaller
  Action As Long
  addr As String
  timer As Single
  ThisCell As Range
  fx As String
  link_location As Variant
  friendly_name As Variant
  tips As Variant
End Type
#If VBA7 Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#Else
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
#End If

#If -VBA7 And -Win64 Then
  Private Declare PtrSafe Function setTimer Lib "user32" Alias "SetTimer" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As LongPtr
  Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As LongPtr
#ElseIf VBA7 Then
  Private Declare PtrSafe Function setTimer Lib "user32" Alias "SetTimer" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
  Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
  Private Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
  Private Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If

''///////////////////////////////////////////////////////
Private Const UDFIDEvent = 31518000
Private Work As UDFDynamicParameters

Function Hyperlink2(ByVal link_location, Optional friendly_name, Optional tips)
  Hyperlink2 = "[Hyperlink]"
  AddUDFDynamicArguments ffsFXMain, link_location, friendly_name, tips
End Function

Private Function AddUDFDynamicArguments(direction&, ParamArray arguments())
  On Error Resume Next
  Dim r As Object, s$, f$
  Set r = Application.caller: f = r.Formula: s = r.Address(0, 0, , 1)
  If s <> ActiveCell.Address(0, 0, , 1) Then Exit Function
  With Work
    .Action = 1: Set .ThisCell = r: .addr = s: .fx = f
    Select Case direction
    Case ffsFXMain:
      .direction = direction
   
      If IsObject(arguments(0)) Then Set .link_location = arguments(0) Else .link_location = arguments(0)
      If IsObject(arguments(1)) Then Set .friendly_name = arguments(1) Else .friendly_name = arguments(1)
      If IsObject(arguments(2)) Then Set .tips = arguments(2) Else .tips = arguments(2)

      Call SetNewTimer(1, , "^z")
    End Select
  End With
End Function


Sub UDFDynamic_working()
  On Error Resume Next
  Dim a As Application, b As UDFDynamicParameters, k&, s$, p$
  Dim su As Boolean, ac As Boolean, ec As Boolean
  Dim w As Object, ws As Object
  Dim r&, lr&, rg, rg2, rg3, o, j%
  With Work
    Select Case .Action
    Case 1:
      GoSub app
      j = TypeName(.tips) = "Range"
      If j Then
        Set rg2 = .tips
      Else
        If .tips <> Empty Then j = 1
      End If
      If TypeName(.link_location) = "Range" Then
        Set rg = .link_location
        lr = rg.Rows.Count
        With .ThisCell.Resize(rg.Rows.Count, rg.Columns.Count)
          .MergeCells = False
          .Hyperlinks.Delete
        End With
        If TypeName(.friendly_name) = "Range" Then
          .friendly_name.Copy .ThisCell
        Else
          rg.Copy .ThisCell
        End If
        r = 1
        Do While r <= lr
          Set o = rg(r, 1)
          Err.Clear
          If CStr(o.Value) <> vbNullString Then
            Select Case j
            Case -1: Call .ThisCell(r, 1).Hyperlinks.Add(.ThisCell(r, 1), Address:=o.Value, ScreenTip:=rg2(r, 1).Value)
            Case 1: Call .ThisCell(r, 1).Hyperlinks.Add(.ThisCell(r, 1), Address:=o.Value, ScreenTip:=.tips)
            Case Else: Call .ThisCell(r, 1).Hyperlinks.Add(.ThisCell(r, 1), Address:=o.Value)
            End Select
          End If
          r = r + o.MergeArea.Rows.Count
        Loop
      Else
        s = IIf(.friendly_name <> "", .friendly_name, .link_location)
        Select Case j
        Case -1: Call .ThisCell.Parent.Hyperlinks.Add(.ThisCell, .link_location, ScreenTip:=rg2(r, 1).Value, TextToDisplay:=s)
        Case 1: Call .ThisCell.Parent.Hyperlinks.Add(.ThisCell, .link_location, ScreenTip:=.tips, TextToDisplay:=s)
        Case Else: Call .ThisCell.Parent.Hyperlinks.Add(.ThisCell, .link_location)
        End Select
      End If
    End Select
  End With
E:
  Work = b
  If Not a Is Nothing Then
    If su And a.ScreenUpdating <> su Then a.ScreenUpdating = su
    If ac = xlCalculationAutomatic And ac <> a.Calculation Then a.Calculation = ac
    If ec And a.EnableEvents <> ec Then a.EnableEvents = ec
  End If
Exit Sub
app:
  If a Is Nothing Then
    Set a = Application
    With a
      ec = .EnableEvents: If ec Then .EnableEvents = False
      su = .ScreenUpdating: If su Then .ScreenUpdating = False
      ac = .Calculation: If ac = xlCalculationAutomatic Then .Calculation = xlCalculationManual
    End With
  End If
Return
End Sub

''///////////////////////////////////////////////////////
Private Sub SetNewTimer(Optional direction As Long, Optional miliSeconds& = 10, Optional keys$)
  On Error Resume Next
  If keys <> vbNullString Then CreateObject("WScript.Shell").sendkeys keys, False
  Dim h1 As LongPtr, h2 As LongPtr
  h1 = Choose(1, AddressOf ProcTimer)
  #If Win64 Then
    h1 = Choose(1, AddressOf FakeProcTimer)
    h2 = Choose(1, AddressOf ProcTimer)
    SwapMemoryAddresses h1, h2
  #End If
  Call setTimer(Application.hWnd, UDFIDEvent + direction, miliSeconds, h1)
End Sub
Private Sub ProcTimer(ByVal hWnd As LongPtr, ByVal wMsg As LongPtr, ByVal idevent As LongPtr, ByVal dwTime As LongPtr)
  On Error Resume Next
  KillTimer hWnd, idevent
  Select Case idevent - UDFIDEvent
  Case 1: Call UDFDynamic_working
  End Select
End Sub
Private Sub FakeProcTimer()
  On Error Resume Next
  Dim w, h As LongPtr
  If Val(Application.ver) > 14 Then
    For Each w In Application.Windows
      h = w.hWnd: KillTimer h, UDFIDEvent + 1
    Next
  Else
    KillTimer Application.hWnd, UDFIDEvent + 1
  End If
End Sub
Private Function SwapMemoryAddresses(ByVal Addrss1 As LongPtr, ByVal Addrss2 As LongPtr)
  Call CopyMemory(ByVal Addrss1 + PTR_LEN * 6& + 4&, ByVal Addrss2 + PTR_LEN * 6& + 4&, PTR_LEN)
End Function

 

[A HOANG 620]

mình cần ghép link cần thiết vào bảng giá trị như thế nào. Anh chị nào cao kiến giúp mình với. cám ơn