Hyperlink for first column of each row running a macro ?

[gopipuli]

Hi

First up all thank you very much for this wonderful forum. I am not good in vba. so I need help from you wonderful people here. I am looking for something like this

I have an excel file which contain two sheets. The first sheet contain my data in rows, the second sheet is a template which I need to open by clicking first column which is a hyperlink to open the respective row data with the second sheet. Like we do in html clicking link and opening details. I manage to gather information from web that this could be done by creating a vba code that copy data from one sheet to other. But I dont know how to link this macro to each row ? Please give me a start on this topic.

 

[mumps]

Try:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Dim lCol As Long, addr As Range, y As Long, x As Long
    x = 8
    y = 2
    lCol = Cells(1, Columns.Count).End(xlToLeft).Column
    With Sheets("Template")
        .Range("B:C,F:F").ClearContents
        .Range("C3") = Target
        .Range("F3") = Target.Offset(, 1)
        .Range("C5") = Target.Offset(, 2)
        .Range("F5") = Target.Offset(, 3)
        For Each addr In Range("E" & Target.Row).Resize(, lCol - 4)
            If addr <> "" Then
                .Cells(x, y) = addr
                If y = 3 Then
                    x = x + 1
                    y = 2
                ElseIf y = 2 Then
                    y = 3
                End If
            End If
        Next addr
    End With
    Cancel = True
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[gopipuli]

Try:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Dim lCol As Long, addr As Range, y As Long, x As Long
    x = 8
    y = 2
    lCol = Cells(1, Columns.Count).End(xlToLeft).Column
    With Sheets("Template")
        .Range("B:C,F:F").ClearContents
        .Range("C3") = Target
        .Range("F3") = Target.Offset(, 1)
        .Range("C5") = Target.Offset(, 2)
        .Range("F5") = Target.Offset(, 3)
        For Each addr In Range("E" & Target.Row).Resize(, lCol - 4)
            If addr <> "" Then
                .Cells(x, y) = addr
                If y = 3 Then
                    x = x + 1
                    y = 2
                ElseIf y = 2 Then
                    y = 3
                End If
            End If
        Next addr
    End With
    Cancel = True
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Thank you .. this code work fine, but few things not coming up.

This part " .Range("B:C,F:F").ClearContents" gives an error saying it is a merge cells so I unmerged it and it works better. But is there any solution to work as it is ?
Second thing is after double clicking the column it is not going to template sheet it still stay in the data sheet itself. can it be solved ? Thank you for helping.

 

[mumps]

You should avoid using merged cells at all cost because they almost always create problems for macros. Do a little research into "CenterAcrossSelection". It has the same visual results as merging cells without actually merging them. Try the macro below. It assumes there are no merged cells.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Dim lCol As Long, addr As Range, y As Long, x As Long
    x = 8
    y = 2
    lCol = Cells(1, Columns.Count).End(xlToLeft).Column
    With Sheets("Template")
        .Range("B:C,F:F").ClearContents
        .Range("C3") = Target
        .Range("F3") = Target.Offset(, 1)
        .Range("C5") = Target.Offset(, 2)
        .Range("F5") = Target.Offset(, 3)
        For Each addr In Range("E" & Target.Row).Resize(, lCol - 4)
            If addr <> "" Then
                .Cells(x, y) = addr
                If y = 3 Then
                    x = x + 1
                    y = 2
                ElseIf y = 2 Then
                    y = 3
                End If
            End If
        Next addr
    End With
    Cancel = True
    Sheets("Template").Activate
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[gopipuli]

You should avoid using merged cells at all cost because they almost always create problems for macros. Do a little research into "CenterAcrossSelection". It has the same visual results as merging cells without actually merging them. Try the macro below. It assumes there are no merged cells.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Dim lCol As Long, addr As Range, y As Long, x As Long
    x = 8
    y = 2
    lCol = Cells(1, Columns.Count).End(xlToLeft).Column
    With Sheets("Template")
        .Range("B:C,F:F").ClearContents
        .Range("C3") = Target
        .Range("F3") = Target.Offset(, 1)
        .Range("C5") = Target.Offset(, 2)
        .Range("F5") = Target.Offset(, 3)
        For Each addr In Range("E" & Target.Row).Resize(, lCol - 4)
            If addr <> "" Then
                .Cells(x, y) = addr
                If y = 3 Then
                    x = x + 1
                    y = 2
                ElseIf y = 2 Then
                    y = 3
                End If
            End If
        Next addr
    End With
    Cancel = True
    Sheets("Template").Activate
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Thank you very much for this wonderful help.

 

[mumps]

My pleasure.