Poniższe podejście wykorzystuje obejście opisane tutaj i tutaj , aby umożliwić funkcji arkusza zdefiniowanej w VBA ustawienie wartości innej komórki.
Funkcja niestandardowa przechowuje w zmiennych globalnych adres komórki docelowej oraz wartość, na jaką ta komórka ma być ustawiona. Następnie makro, które jest uruchamiane podczas przeliczania arkusza, odczytuje zmienne globalne i ustawia komórkę docelową na określoną wartość.
Użycie funkcji niestandardowej jest proste:
=SetCellValue(target_cell, value)
gdzie target_cell
jest łańcuchowym odniesieniem do komórki w arkuszu (np. “A1”) lub wyrażeniem, które ocenia się na takie odniesienie. Obejmuje to wyrażenie takie jak =B14
, gdzie wartością B14 jest “A1”. Funkcję można zastosować w dowolnym prawidłowym wyrażeniu.
SetCellValue
zwraca 1, jeżeli wartość została pomyślnie zapisana do komórki docelowej, a 0 w przeciwnym przypadku. Wszelkie poprzednie zawartości komórki docelowej są nadpisywane.
Potrzebne są trzy fragmenty kodu:
- kod definiujący sam
SetCellValue
- makro, które jest wywoływane przez zdarzenie obliczenia arkusza; oraz
- funkcja użytkowa
IsCellAddress
zapewniająca, że target_cell
jest prawidłowym adresem komórki.
Kod dla funkcji SetCellValue
Kod ten należy wkleić do standardowego modułu wstawianego do skoroszytu. Moduł można wstawić za pomocą menu edytora Visual Basic, do którego wchodzi się, wybierając Visual Basic
z zakładki Developer
wstążki.
Option Explicit
Public triggerIt As Boolean
Public theTarget As String
Public theValue As Variant
Function SetCellValue(aCellAddress As String, aValue As Variant) As Long
If (IsCellAddress(aCellAddress)) And _
(Replace(Application.Caller.Address, "$", "") <> _
Replace(UCase(aCellAddress), "$", "")) Then
triggerIt = True
theTarget = aCellAddress
theValue = aValue
SetCellValue = 1
Else
triggerIt = False
SetCellValue = 0
End If
End Function
Arkusz roboczy Kod makra obliczeniowego
Kod ten musi znaleźć się w kodzie właściwym dla arkusza, w którym będziemy używać SetCellValue
. Najprostszym sposobem jest kliknięcie prawym przyciskiem myszy na zakładce arkusza w widoku Home
, wybranie opcji View Code
, a następnie wklejenie kodu w okienku edytora, które się pojawi.
Private Sub Worksheet_Calculate()
If Not triggerIt Then
Exit Sub
End If
triggerIt = False
On Error GoTo CleanUp
Application.EnableEvents = False
Range(theTarget).Value = theValue
CleanUp:
Application.EnableEvents = True
Application.Calculate
End Sub
Kod dla funkcji IsCellAddress
Ten kod można wkleić do tego samego modułu co kod SetCellValue
.
Function IsCellAddress(aValue As Variant) As Boolean
IsCellAddress = False
Dim rng As Range ' Input is valid cell reference if it can be
On Error GoTo GetOut ' assigned to range variable
Set rng = Range(aValue)
On Error GoTo 0
Dim colonPos As Long 'convert single cell "range" address to
colonPos = InStr(aValue, ":") 'single cell reference ("A1:A1" -> "A1")
If (colonPos <> 0) Then
If (Left(aValue, colonPos - 1) = _
Right(aValue, Len(aValue) - colonPos)) Then
aValue = Left(aValue, colonPos - 1)
End If
End If
If (rng.Rows.Count = 1) And _
(rng.Columns.Count = 1) And _
(InStr(aValue, "!") = 0) And _
(InStr(aValue, ":") = 0) Then
IsCellAddress = True
End If 'must be single cell address in this worksheet
Exit Function
GetOut:
End Function