Excel에서 UDF를 사용하여 워크시트 업데이트
질문은 아니지만, 이전에 이 접근 방식을 본 기억이 없기 때문에 댓글을 달기 위해 이 글을 올립니다.저는 이전 답변에 대한 댓글에 답하다가 전에 시도하지 않았던 것을 시도했습니다: 결과가 흥미로워서 저의 답변과 함께 단독 질문으로 게시하려고 했습니다.
SO(및 다른 많은 포럼)에 대해 "사용자 정의 기능에 문제가 있는 것은 무엇입니까?"라는 질문이 많이 제기되었습니다. 여기서 답변은 "UDF에서 워크시트를 업데이트할 수 없습니다."였습니다. 이 제한 사항은 다음과 같습니다.
Excel에서 사용자 지정 기능의 제한 사항에 대한 설명
이를 극복하기 위해 설명된 몇 가지 방법이 있습니다. 예를 들어 여기(https://sites.google.com/site/e90e50/excel-formula-to-change-the-value-of-another-cell) )를 참조하십시오. 하지만 저의 정확한 접근 방식은 그 중 하나라고 생각하지 않습니다.
내 "질문"을 답변이 있는 것으로 표시할 수 있도록 답변을 게시하는 것.
다른 해결 방법을 알아봤지만, 이 방법이 더 간단한 것 같고 작동하는 것에 놀랐습니다.
Sub ChangeIt(c1 As Range, c2 As Range)
c1.Value = c2.Value
c1.Interior.Color = IIf(c1.Value > 10, vbRed, vbYellow)
End Sub
'######## run as a UDF, this actually changes the sheet ##############
' changing value in c2 updates c1...
Function SetIt(src, dest)
dest.Parent.Evaluate "Changeit(" & dest.Address(False, False) & "," _
& src.Address(False, False) & ")"
SetIt = "Changed sheet!" 'or whatever return value is useful...
End Function
공유하고 싶은 흥미로운 응용 프로그램이 있으면 추가 답변을 게시하십시오.
참고: 실제 "운영" 애플리케이션에서는 테스트되지 않았습니다.
MSDN KB가 잘못되었습니다.
라고 써있습니다
워크시트 셀의 수식으로 호출되는 사용자 정의 함수는 Microsoft Excel의 환경을 변경할 수 없습니다.즉, 이러한 함수는 다음 작업을 수행할 수 없습니다.
- 스프레드시트에 셀을 삽입, 삭제 또는 포맷합니다.
- 다른 셀의 값을 변경합니다.
- 워크북에 시트를 이동, 이름 변경, 삭제 또는 추가합니다.
- 계산 모드 또는 화면 보기와 같은 환경 옵션을 변경합니다.
- 워크북에 이름을 추가합니다.
- 속성을 설정하거나 대부분의 메서드를 실행합니다.
아래 코드에서 1, 2, 4 및 5 지점이 쉽게 달성되는 것을 볼 수 있습니다.
Function SetIt(RefCell)
RefCell.Parent.Evaluate "SetColor(" & RefCell.Address(False, False) & ")"
RefCell.Parent.Evaluate "SetValue(" & RefCell.Address(False, False) & ")"
RefCell.Parent.Evaluate "AddName(" & RefCell.Address(False, False) & ")"
MsgBox Application.EnableEvents
RefCell.Parent.Evaluate "ChangeEvents(" & RefCell.Address(False, False) & ")"
MsgBox Application.EnableEvents
SetIt = ""
End Function
'~~> Format cells on the spreadsheet.
Sub SetColor(RefCell As Range)
RefCell.Interior.ColorIndex = 3 '<~~ Change color to red
End Sub
'~~> Change another cell's value.
Sub SetValue(RefCell As Range)
RefCell.Offset(, 1).Value = "Sid"
End Sub
'~~> Add names to a workbook.
Sub AddName(RefCell As Range)
RefCell.Name = "Sid"
End Sub
'~~> Change events
Sub ChangeEvents(RefCell As Range)
Application.EnableEvents = False
End Sub
저는 이것이 오래된 스레드라는 것을 알고 있고, 여러분 중 누구도 이것을 이미 발견했는지는 모르겠지만, 저는 UDF에서 도형을 추가, 삭제 또는 수정할 수 있을 뿐만 아니라, 추가할 수도 있다는 것을 발견했습니다.Querytables나는 직장에서 이 개념을 사용하여 특정 범위의 값이 주어진 SQL 데이터를 반환하는 애드인을 구축하고 있습니다.Ctrl+Shift+Enter배열 함수의 방법, 왜냐하면 많은 내 최종 사용자들이 그들의 사용을 이해할 만큼 뛰어난 지식을 가지고 있지 않기 때문입니다.
참고: 아래 코드는 테스트 단계에서 100%이며 개선의 여지가 많지만 개념을 설명합니다.또한 그것은 괜찮은 코드이지만, 저는 어떤 것도 의문을 남기고 싶지 않았습니다.
Option Explicit
Public Function GetPNAverages(ByRef RangeSource As Range) As Variant
Dim arrySheet As Variant
Dim lngRowCount As Long, i As Long
Dim strSQL As String
Dim rngOut As Range
Dim objQryTbl As QueryTable
Dim dictSQLData As Dictionary
Dim RcrdsetReturned As ADODB.Recordset, RcrdsetOut As ADODB.Recordset
Dim Conn As ADODB.Connection
Application.ScreenUpdating = False
If RangeSource.Columns.Count > 1 Then
MsgBox "The input Range cannot be more than" _
& " a single column.", vbCritical + vbOKOnly, "Error:" _
& " Invalid Range Dimensions"
Exit Function
End If
lngRowCount = RangeSource.Rows.Count
If RngHasData(Application.Caller.Address, lngRowCount) Then Exit Function
arrySheet = RangeSource
strSQL = ArryToDelimStr(arrySheet, lngRowCount)
If Not GetRecordSet(strSQL, "JDE.GetPNAveragesTEST", _
"@STR_PN", RcrdsetReturned, Conn) Then GoTo StopExecution
Call BuildDictionary(dictSQLData, RcrdsetReturned, lngRowCount)
Call LeftOuterJoin(dictSQLData, arrySheet, RcrdsetOut, lngRowCount)
GetPNAverages = dictSQLData.Item(RangeSource.Cells(1, 1).Value2) 'first value
If lngRowCount > 1 Then
'Place query table below first cell
Set rngOut = Range(Application.Caller.Address).Offset(1, 0)
'add query table to the range
Set objQryTbl = ActiveWorkbook.ActiveSheet.QueryTables.Add(RcrdsetOut, rngOut)
With objQryTbl
.FieldNames = False
.RefreshStyle = xlOverwriteCells
.BackgroundQuery = False
.AdjustColumnWidth = False
.PreserveColumnInfo = True
.PreserveFormatting = True
.Refresh
End With
'deletes any query table from _
ots destination range to avoid _
having external connections
rngOut.QueryTable.Delete
End If
StopExecution:
Application.ScreenUpdating = True
Application.EnableEvents = True
If Not Conn Is Nothing Then: If Conn.State > 0 Then Conn.Close
If Not RcrdsetReturned Is Nothing Then: If RcrdsetReturned.State > 0 Then RcrdsetReturned.Close
If Not RcrdsetOut Is Nothing Then: If RcrdsetOut.State > 0 Then RcrdsetOut.Close
Set Conn = Nothing
Set RcrdsetReturned = Nothing
Set RcrdsetOut = Nothing
End Function
Private Function GetRecordSet(ByRef strDelimIn As String, ByVal strStoredProcName As String, _
ByVal strStrdProcParam As String, ByRef RcrdsetIn As ADODB.Recordset, _
ByRef ConnIn As ADODB.Connection) As Boolean
Dim Cmnd As ADODB.Command
Const strConn = "Provider=VersionOfSQL;User ID=************;Password=************;" & _
"Data Source=ServerName;Initial Catalog=DataBaseName"
On Error GoTo ErrQueryingData
Set ConnIn = New ADODB.Connection
ConnIn.CursorLocation = adUseClient 'this is key for query table to work
ConnIn.Open strConn
Set Cmnd = New ADODB.Command
With Cmnd
.CommandType = adCmdStoredProc
.CommandText = strStoredProcName
.CommandTimeout = 300
.ActiveConnection = ConnIn
End With
Set RcrdsetIn = New ADODB.Recordset
Cmnd.Parameters(strStrdProcParam).Value = strDelimIn
RcrdsetIn.CursorType = adOpenKeyset
RcrdsetIn.LockType = adLockReadOnly
Set RcrdsetIn = Cmnd.Execute
If RcrdsetIn.EOF Or RcrdsetIn.BOF Then GoTo ErrQueryingData Else GetRecordSet = True
Set Cmnd = Nothing
Exit Function
ErrQueryingData:
If Not ConnIn Is Nothing Then: If ConnIn.State > 0 Then ConnIn.Close
If Not RcrdsetIn Is Nothing Then: If RcrdsetIn.State > 0 Then RcrdsetIn.Close
Set ConnIn = Nothing
Set RcrdsetIn = Nothing
Set Cmnd = Nothing
'Sometimes the error numer <> > 0 hence the else statement
If Err.Number > 0 Then
MsgBox "Error Number: " & Err.Number & "- " & Err.Description & _
" , occured while attempting to exectute the query.", _
vbCritical, "Error: " & Err.Number
Else
MsgBox "An error occured while attempting to execute the query. " & _
"Try typing the formula again. If the issue persits" & _
"please contact (Developer Name).", vbCritical, _
"Error: Could Not Query Data"
End If
End Function
Private Sub BuildDictionary(ByRef dictToReturn As Dictionary, ByRef RcrdsetIn As ADODB.Recordset, _
ByVal lngRowCountIn As Long)
'building a second recordset because I only want one field from the
'recordset returned by 'GetRecordSet', and I cannot subset it
'using any properties of the query table that I know of
Set dictToReturn = New Dictionary
dictToReturn.CompareMode = BinaryCompare
With RcrdsetIn
If lngRowCountIn > 1 Then
.MoveFirst
Do While Not RcrdsetIn.EOF
'Populate dictionary with key=LookUpValues; Item=ReturnValues
If Not dictToReturn.Exists(.Fields(0).Value) Then
dictToReturn(.Fields(0).Value) = .Fields(1).Value
End If
.MoveNext
Loop
Else 'only 1 value
dictToReturn(.Fields(0).Value) = .Fields(1).Value
End If
End With
End Sub
Private Sub LeftOuterJoin(ByRef dictIn As Dictionary, ByRef arryInPut As Variant, _
ByRef RcrdsetToReturn As ADODB.Recordset, ByVal lngRowCountIn As Long)
Dim i As Long
Dim varKey As Variant
If lngRowCountIn = 1 Then Exit Sub
Set RcrdsetToReturn = New ADODB.Recordset
With RcrdsetToReturn
.Fields.Append "Field1", adVariant, 10, adFldMayBeNull
.CursorType = adOpenKeyset
.LockType = adLockBatchOptimistic
.CursorLocation = adUseClient
.Open
If Not .BOF Then .MoveNext
'LBound(arryInPut, 1) + 1 skip first value of array
For i = LBound(arryInPut, 1) + 1 To UBound(arryInPut, 1)
.AddNew
varKey = arryInPut(i, 1)
If dictIn.Exists(varKey) Then
.Fields(0).Value = dictIn.Item(varKey)
Else
.Fields(0).Value = "DNE"
End If
varKey = Empty
.Update
.MoveNext
Next i
End With
End Sub
Private Function ArryToDelimStr(ByRef arryFromRngIn As Variant, ByVal lngRowCountIn As Long) As String
Dim arryOutPut() As Variant
Dim i As Long
Const strDelim As String = "|"
If lngRowCountIn = 1 Then
ArryToDelimStr = arryFromRngIn
Exit Function
End If
'Note: 1-based to match the worksheet array
ReDim arryOutPut(1 To lngRowCountIn)
For i = LBound(arryFromRngIn, 1) To lngRowCountIn
arryOutPut(i) = arryFromRngIn(i, 1)
Next i
ArryToDelimStr = Join(arryOutPut, strDelim)
End Function
Public Function RngHasData(ByVal strCallAddress As String, ByVal lngRowCountIn As Long) As Boolean
Dim strRangeBegin As String, strRangeOut As String, _
strCheckUserInput As String
Dim lngRangeBegin As Long, lngRangeEnd As Long
strRangeBegin = StripNumbers(strCallAddress)
lngRangeBegin = StripText(strCallAddress)
lngRangeEnd = lngRangeBegin + lngRowCountIn
strRangeOut = strCallAddress & ":" & strRangeBegin & CStr(lngRangeEnd)
If Application.CountA(ActiveSheet.Range(strRangeOut)) > 1 Then
strCheckUserInput = MsgBox("There is data in range " & strRangeOut & " are you sure" & _
"that you want to overwrite it?", vbInformation _
+ vbYesNo, "Alert: Data In This Range")
If strCheckUserInput = vbNo Then RngHasData = True
End If
End Function
Private Function StripText(ByRef strIn As String) As Long
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "[^\d]+"
StripText = CLng(.Replace(strIn, vbNullString))
End With
End Function
Private Function StripNumbers(strIn As String) As String
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "\d+"
StripNumbers = .Replace(strIn, "")
End With
End Function
구분된 문자열을 테이블 변수로 구문 분석하는 테이블 값 함수:
SET ANSI_NULLS ON
GO
SET QUOTED_IDENTIFIER ON
GO
CREATE FUNCTION dbo.fn_Get_REGDelimStringToTable (@STR_IN NVARCHAR(MAX))
RETURNS @TableOut TABLE(ReturnedCol NVARCHAR(4000))
AS
BEGIN
DECLARE @XML xml = N'<r><![CDATA[' + REPLACE(@STR_IN, '|', ']]></r><r><![CDATA[') + ']]></r>'
INSERT INTO @TableOut(ReturnedCol)
SELECT RTRIM(LTRIM(T.c.value('.', 'NVARCHAR(4000)')))
FROM @xml.nodes('//r') T(c)
RETURN
END
GO
사용된 저장 프로시저:
CREATE PROCEDURE [JDE].[GetPNAveragesTEST] ( @STR_PN NVARCHAR(MAX)
) AS
BEGIN
SELECT TT.ReturnedCol
,IsNull(Cast(pnm.AVERAGE_COST As nvarchar(35)), 'DNE') as AVERAGE_COST
FROM dbo.fn_Get_MAXDelimStringToTable(@STR_PN) TT
Left Join PN_Interchangeable pni ON TT.ReturnedCol=pni.PN_Interchangeable
Left Join PN_MASTER pnm On pni.MPN=pnm.MPN
END;
언급URL : https://stackoverflow.com/questions/23433096/using-a-udf-in-excel-to-update-the-worksheet
'programing' 카테고리의 다른 글
| Swift를 사용하여 키보드로 보기 이동 (0) | 2023.05.04 |
|---|---|
| 의 시간 제한을 변경하는 방법.NET WebClient 개체 (0) | 2023.05.04 |
| Git 커밋을 아직 오리진에 푸시하지 않은 목록 (0) | 2023.05.04 |
| Git remote에서 풀링할 때 원격 변경을 사용하여 충돌 해결 (0) | 2023.05.04 |
| Mongo에서 문자열로 BinData UUID 가져오기 (0) | 2023.05.04 |