W
Wingman
After searching in this group and lots of trial and error, I've
finally managed to get the following working:
1. Select a range on my sheet with form object in it, which have
linked cells to some cells (possibly on another sheet).
2. Have a macro change those links all at once to cells a couple of
rows lower.
This makes copying several comboboxen and listboxes a lot easier..
the code is for future users to spare them the work:
Sub TransposeLinkedCell()
offset = inputbox("Hoeveel regels moeten de verwijzigen in de
selectie veranderen? (+1 = naar onderen, -1 = naar boven)", "Verander
verwijzing", 15)
For Each s In ActiveSheet.Shapes
With s.BottomRightCell
If .Row > Selection.Row And .Row < Selection.Row +
Selection.Rows.Count Then
If s.ControlFormat.LinkedCell <> "" Then
Dim sheet, addr, fulladdr As String
fulladdr = s.ControlFormat.LinkedCell
Dim index As Integer
On Error Resume Next 'if no exclamation is found,
just resume
index = Application.WorksheetFunction.Search("!",
fulladdr)
If index > 0 Then
sheet = Left(s.ControlFormat.LinkedCell,
index)
End If
addr = Right(s.ControlFormat.LinkedCell,
Len(fulladdr) - index)
addr = ActiveSheet.Range(addr).offset(15).Address
s.ControlFormat.LinkedCell = sheet & addr
End If
End If
End With
Next
End Sub
finally managed to get the following working:
1. Select a range on my sheet with form object in it, which have
linked cells to some cells (possibly on another sheet).
2. Have a macro change those links all at once to cells a couple of
rows lower.
This makes copying several comboboxen and listboxes a lot easier..
the code is for future users to spare them the work:
Sub TransposeLinkedCell()
offset = inputbox("Hoeveel regels moeten de verwijzigen in de
selectie veranderen? (+1 = naar onderen, -1 = naar boven)", "Verander
verwijzing", 15)
For Each s In ActiveSheet.Shapes
With s.BottomRightCell
If .Row > Selection.Row And .Row < Selection.Row +
Selection.Rows.Count Then
If s.ControlFormat.LinkedCell <> "" Then
Dim sheet, addr, fulladdr As String
fulladdr = s.ControlFormat.LinkedCell
Dim index As Integer
On Error Resume Next 'if no exclamation is found,
just resume
index = Application.WorksheetFunction.Search("!",
fulladdr)
If index > 0 Then
sheet = Left(s.ControlFormat.LinkedCell,
index)
End If
addr = Right(s.ControlFormat.LinkedCell,
Len(fulladdr) - index)
addr = ActiveSheet.Range(addr).offset(15).Address
s.ControlFormat.LinkedCell = sheet & addr
End If
End If
End With
Next
End Sub