创建 Excel 可以对混合数字和文本求和的用户定义函数 (UDF)
Create Excel User Defined Function (UDF) that can sum mixed numbers and text
excel中的数据示例：
COL A B C D F.....
1 SL.....
2 SL8 AL4 CD3 CN5 CD4 AL8
我根据单元格内的字母标识符有条件地求和。 UDF 被输入单元格 (F2) =SumDigByLTR2(A2:C2,F1)，其中 F1 - I1 是求和的条件（字母、SL、AL 等）。结果应该是：
SL=8
AL=12
CD=7
CN=5
我在 VBA（下）中创建了这个用户定义的函数。我修改了一些我在网上找到的代码。它起初有效，然后神秘地停止工作。我不记得对 XLS 或 VBA 进行过任何更改。想法？
您可以忽略注释掉的 "delim" 行。我试图有一个选项来设置字母之间的分隔符。它没有用，所以我只使用 space。
Option Explicit
Function SumDigByLTR2(rg As Range, ltr As String) As Double
Dim c As Range 'c = a cell
Dim delimiter As String
Dim InStrResult As Long 'returns the position of "ltr" in the cell e.g. abc34, if ltr="c", then Instr() = 3
Dim MidResult As Long
Dim numltr As Integer 'number of characters in the critera, i.e. AL or A
'Dim delim_text As String 'this will identify the user preferred demlimiter text.
Dim StartPos As Integer 'position of ltr + number of characters in the critera, i.e. AL or A
Dim DelimPos As Integer 'position of delimiter after "ltr"
Dim numlen As Integer 'returns length of the desired numbers i.e. "3" =1 or "10" =2
For Each c In rg
'delimiter = Sheet7.Range("O8").Value
InStrResult = InStr(1, c.Text, ltr, vbTextCompare)
If InStr(1, c.Text, ltr, vbTextCompare) > 0 Then
StartPos = InStrResult + Len(ltr)
DelimPos = InStr(InStrResult, c.Text, " ") 'Sheet7.Cells(8, 15).Value) '"O"=15
If DelimPos = 0 Then
MidResult = Right(c.Text, Len(c.Text) - StartPos + 1) '"+1" because if cell=al3; starpos will = 3 & len(cell)=3; therefore Len-startpos=0
Else
numlen = DelimPos - StartPos + 1
MidResult = Mid(c.Text, StartPos, numlen)
End If
SumDigByLTR2 = SumDigByLTR2 + MidResult
End If
Next c
End Function
'Original
'http://www.pcreview.co.uk/forums/excel-extract-and-sum-numerals-mixed-text-numeral-cell-range-t937450.html
'Option Explicit
'Function SumDigByLtr(rg As Range, ltr As String) As Double
'Dim c As Range
'For Each c In rg
'If InStr(1, c.Text, ltr) > 0 Then
'SumDigByLtr = SumDigByLtr + Replace(c.Text, ltr, "")
'End If
'Next c
'End Function
更新 #1，2015 年 11 月 25 日
我发现是什么破坏了我的 UDF。
Excel 2010年好像又创作了一套新作品sheet，把原来的都改名了，比如Sheet10 变为 Sheet101，Sheet13 变为 Sheet131。这会导致 UDF 停止运行。 "new" "sheet10" 和 "sheet13" 似乎不存在于 VBA 项目 window 中。 "new" sheet 旁边有一个蓝色图标。
我不得不将 UDF 中的引用更改为新的 sheet 名称，因为 Excel 创建了 "new" sheet 并重命名了我的 "old" sheets 是独立的。没有更多的#VALUE 错误。
有谁知道是什么导致 Excel/VBA 创建这些不存在的 sheet 并重命名原来的 sheet？
更新 #2，2016 年 1 月 6 日
我在 12 月初将所有真实的、现有的 sheet 复制到一个新的工作簿中。
到今天为止，这个新工作簿中的公式在我打开它时再次全是错误 (#VALUE)。 Excel 没有创建我上次更新中看到的不存在的 sheet。上周 XLS 和公式起作用了，我没有做任何改变。原始工作簿（图中显示的工作簿不存在 sheets）没有 #VALUE 错误。两个工作簿都在同一台计算机上，并且在上个月一起更新了 + 以供比较。
更新 3，2016 年 1 月 6 日
我只是不小心移动了一个文本单元格，然后单击撤消，所有#VALUE 错误都消失了，我现在有了所有正确的计算。卧槽
这是我最后的 UDF。
Option Explicit
Function Sumbytext(rg As Range, ltr As String) As Double
'Similar to Excel SumIf, except that text can be in the cell with the number.
'That text ("ltr") can identify the number, as a condition to sum.
'e.g. Cell1 (D5 T8 Y3), Cell2(D3 A2), Cell3 (T8) >>> Sums: D=8 T=16 Y=3 A=2
Dim c As Range 'c = a cell
Dim InStrResult As Integer 'returns the position of "ltr" in the cell
e.g. abc34, if ltr="c", then Instr() = 3
Dim MidResult As Double
Dim numltr As Integer 'number of characters in the critera, i.e. AL or A
Dim StartPos As Integer 'position of ltr + number of characters in the critera, i.e. AL or A
Dim DelimPos As Integer 'position of delimiter after "ltr"
Dim numlen As Integer 'returns length of the desired numbers i.e. "3" =1 or "10" =2
Dim Abbr As Range 'abbreviation of holiday - this is displayed on the calendar
Dim rgAbbr As Range 'the list of abbreviations corresponding to the list of holidays
Set rgAbbr = Worksheets("Holidays").Range("List_HolAbbr")
For Each c In rg
For Each Abbr In rgAbbr
If UCase(c) = UCase(Abbr) Then GoTo skipcell 'skip cell if the holiday names are in the cell >> 'Labor day' gives an error because the function looking for a cell containing "LA". Therefore exclude "Labor".
Next Abbr
If InStr(1, c.Text, UCase("OCT"), vbTextCompare) > 0 Then GoTo skipcell 'skip cell if it inscludes "Oct". >> results in error due to the "CT" being used as "ltr".
InStrResult = InStr(1, c.Text, ltr, vbTextCompare)
If InStrResult > 0 Then
StartPos = InStrResult + Len(ltr)
DelimPos = InStr(InStrResult, c.Text, " ")
If DelimPos = 0 Then
MidResult = Right(c.Text, Len(c.Text) - StartPos + 1) '"+1" because if cell=al3; starpos will = 3 & len(cell)=3; therefore Len-startpos=0
Else
numlen = DelimPos - StartPos + 1
MidResult = Mid(c.Text, StartPos, numlen)
End If
Sumbytext = Sumbytext + MidResult
End If
skipcell:
Next c
End Function
更新 #1
由于 sheet 名称被 Excel 自动重命名，上面 UPDATE#1 中显示的工作簿问题似乎是破坏我的 UDF 的原因。我必须将 UDF 中的引用更改为新的 sheet 名称，因为 Excel 创建了 "new" sheets 并重命名了我的 "old" sheets在其自己的。没有更多的#VALUE 错误。
更新#2：
我不知道上面的更新#2 中的#VALUE 错误是如何或为什么被修复的。建议？
excel中的数据示例：
COL A B C D F.....
1 SL.....
2 SL8 AL4 CD3 CN5 CD4 AL8
我根据单元格内的字母标识符有条件地求和。 UDF 被输入单元格 (F2) =SumDigByLTR2(A2:C2,F1)，其中 F1 - I1 是求和的条件（字母、SL、AL 等）。结果应该是：
SL=8
AL=12
CD=7
CN=5
我在 VBA（下）中创建了这个用户定义的函数。我修改了一些我在网上找到的代码。它起初有效，然后神秘地停止工作。我不记得对 XLS 或 VBA 进行过任何更改。想法？
您可以忽略注释掉的 "delim" 行。我试图有一个选项来设置字母之间的分隔符。它没有用，所以我只使用 space。
Option Explicit
Function SumDigByLTR2(rg As Range, ltr As String) As Double
Dim c As Range 'c = a cell
Dim delimiter As String
Dim InStrResult As Long 'returns the position of "ltr" in the cell e.g. abc34, if ltr="c", then Instr() = 3
Dim MidResult As Long
Dim numltr As Integer 'number of characters in the critera, i.e. AL or A
'Dim delim_text As String 'this will identify the user preferred demlimiter text.
Dim StartPos As Integer 'position of ltr + number of characters in the critera, i.e. AL or A
Dim DelimPos As Integer 'position of delimiter after "ltr"
Dim numlen As Integer 'returns length of the desired numbers i.e. "3" =1 or "10" =2
For Each c In rg
'delimiter = Sheet7.Range("O8").Value
InStrResult = InStr(1, c.Text, ltr, vbTextCompare)
If InStr(1, c.Text, ltr, vbTextCompare) > 0 Then
StartPos = InStrResult + Len(ltr)
DelimPos = InStr(InStrResult, c.Text, " ") 'Sheet7.Cells(8, 15).Value) '"O"=15
If DelimPos = 0 Then
MidResult = Right(c.Text, Len(c.Text) - StartPos + 1) '"+1" because if cell=al3; starpos will = 3 & len(cell)=3; therefore Len-startpos=0
Else
numlen = DelimPos - StartPos + 1
MidResult = Mid(c.Text, StartPos, numlen)
End If
SumDigByLTR2 = SumDigByLTR2 + MidResult
End If
Next c
End Function
'Original
'http://www.pcreview.co.uk/forums/excel-extract-and-sum-numerals-mixed-text-numeral-cell-range-t937450.html
'Option Explicit
'Function SumDigByLtr(rg As Range, ltr As String) As Double
'Dim c As Range
'For Each c In rg
'If InStr(1, c.Text, ltr) > 0 Then
'SumDigByLtr = SumDigByLtr + Replace(c.Text, ltr, "")
'End If
'Next c
'End Function
更新 #1，2015 年 11 月 25 日 我发现是什么破坏了我的 UDF。
Excel 2010年好像又创作了一套新作品sheet，把原来的都改名了，比如Sheet10 变为 Sheet101，Sheet13 变为 Sheet131。这会导致 UDF 停止运行。 "new" "sheet10" 和 "sheet13" 似乎不存在于 VBA 项目 window 中。 "new" sheet 旁边有一个蓝色图标。
我不得不将 UDF 中的引用更改为新的 sheet 名称，因为 Excel 创建了 "new" sheet 并重命名了我的 "old" sheets 是独立的。没有更多的#VALUE 错误。
有谁知道是什么导致 Excel/VBA 创建这些不存在的 sheet 并重命名原来的 sheet？
更新 #2，2016 年 1 月 6 日
我在 12 月初将所有真实的、现有的 sheet 复制到一个新的工作簿中。
到今天为止，这个新工作簿中的公式在我打开它时再次全是错误 (#VALUE)。 Excel 没有创建我上次更新中看到的不存在的 sheet。上周 XLS 和公式起作用了，我没有做任何改变。原始工作簿（图中显示的工作簿不存在 sheets）没有 #VALUE 错误。两个工作簿都在同一台计算机上，并且在上个月一起更新了 + 以供比较。
更新 3，2016 年 1 月 6 日 我只是不小心移动了一个文本单元格，然后单击撤消，所有#VALUE 错误都消失了，我现在有了所有正确的计算。卧槽
这是我最后的 UDF。
Option Explicit
Function Sumbytext(rg As Range, ltr As String) As Double
'Similar to Excel SumIf, except that text can be in the cell with the number.
'That text ("ltr") can identify the number, as a condition to sum.
'e.g. Cell1 (D5 T8 Y3), Cell2(D3 A2), Cell3 (T8) >>> Sums: D=8 T=16 Y=3 A=2
Dim c As Range 'c = a cell
Dim InStrResult As Integer 'returns the position of "ltr" in the cell
e.g. abc34, if ltr="c", then Instr() = 3
Dim MidResult As Double
Dim numltr As Integer 'number of characters in the critera, i.e. AL or A
Dim StartPos As Integer 'position of ltr + number of characters in the critera, i.e. AL or A
Dim DelimPos As Integer 'position of delimiter after "ltr"
Dim numlen As Integer 'returns length of the desired numbers i.e. "3" =1 or "10" =2
Dim Abbr As Range 'abbreviation of holiday - this is displayed on the calendar
Dim rgAbbr As Range 'the list of abbreviations corresponding to the list of holidays
Set rgAbbr = Worksheets("Holidays").Range("List_HolAbbr")
For Each c In rg
For Each Abbr In rgAbbr
If UCase(c) = UCase(Abbr) Then GoTo skipcell 'skip cell if the holiday names are in the cell >> 'Labor day' gives an error because the function looking for a cell containing "LA". Therefore exclude "Labor".
Next Abbr
If InStr(1, c.Text, UCase("OCT"), vbTextCompare) > 0 Then GoTo skipcell 'skip cell if it inscludes "Oct". >> results in error due to the "CT" being used as "ltr".
InStrResult = InStr(1, c.Text, ltr, vbTextCompare)
If InStrResult > 0 Then
StartPos = InStrResult + Len(ltr)
DelimPos = InStr(InStrResult, c.Text, " ")
If DelimPos = 0 Then
MidResult = Right(c.Text, Len(c.Text) - StartPos + 1) '"+1" because if cell=al3; starpos will = 3 & len(cell)=3; therefore Len-startpos=0
Else
numlen = DelimPos - StartPos + 1
MidResult = Mid(c.Text, StartPos, numlen)
End If
Sumbytext = Sumbytext + MidResult
End If
skipcell:
Next c
End Function
更新 #1 由于 sheet 名称被 Excel 自动重命名，上面 UPDATE#1 中显示的工作簿问题似乎是破坏我的 UDF 的原因。我必须将 UDF 中的引用更改为新的 sheet 名称，因为 Excel 创建了 "new" sheets 并重命名了我的 "old" sheets在其自己的。没有更多的#VALUE 错误。
更新#2：
我不知道上面的更新#2 中的#VALUE 错误是如何或为什么被修复的。建议？