Option Explicit
Public Sub TZ_in_Markierung_Pruefen()
'关闭屏幕更新2023.10.16
Application.ScreenUpdating = False
'这段VBA代码定义了一个名为TZ_in_Markierung_Pruefen的公共子程序。
'该子程序的主要功能是检查选定区域中的单元格值是否满足特定条件（长度小于等于14），如果满足条件，则调用TZ_Pruefen函数对单元格值进行处理。
'处理后的值将替换原来的值，并在需要时添加注释。最后，代码将选定区域的格式设置为数字格式，并调整水平对齐方式。
'如果没有选择任何区域，将弹出一个消息框提示用户。如果在执行过程中发生错误，将弹出一个包含错误描述的消息框，并继续执行后续操作。
Dim gesM As Range
Dim neuerWert As Variant
Dim i As Long
On Error GoTo Err_TZ_in_Markierung_Pruefen
Application.Cursor = xlWait '沙漏
If Not IsNull(Application.Selection) Then
Set gesM = Application.Selection
For i = 1 To gesM.Cells.Count
If Len(Trim(gesM.Cells(i).Value)) <= 18 Then
'将14改为18 2023.10.16
neuerWert = TZ_Pruefen(gesM.Cells(i).Value)
If Len(neuerWert) <> 14 Then
'无
Else
If Trim(gesM.Cells(i).Value) <> neuerWert Then
'评论中的原始值
If gesM.Cells(i).Comment Is Nothing Then
gesM.Cells(i).AddComment "原始值: " & gesM.Cells(i).Value
gesM.Cells(i).Value = neuerWert
Else '可发表评论
gesM.Cells(i).Value = neuerWert
End If
End If
End If
End If
Next i
gesM.Select
'以数字格式 "0 "重新设置选定单元格的格式，使长文本不以指数符号显示
gesM.NumberFormatLocal = "0" '数字格式
gesM.HorizontalAlignment = xlLeft '对齐 林斯本迪格
Else
MsgBox "Keine Markierung vorhanden! - Funktion kann nicht ausgefuehrt werden!"
End If
Exit_TZ_In_Markierung_Pruefen:
Application.Cursor = xlDefault
Exit Sub
Err_TZ_in_Markierung_Pruefen:
MsgBox Err.Description
Resume Exit_TZ_In_Markierung_Pruefen
'恢复屏幕更新 2023.10.16
Application.ScreenUpdating = True
End Sub
Private Function TZ_Pruefen(vTeilzeichen As Variant) As Variant
'这是一个VBA函数，名为TZ_Pruefen，它接受一个参数vTeilzeichen。这个函数的主要目的是将指定的字符串转换为Eickhoff子串格式。以下是该函数的详细解释和代码：
'首先，函数声明了一些变量，如Nr、ZeichLiVonNr、ZeichLiVonNr、ZeichReVonNr$等，用于存储中间结果。
'然后，函数使用UCase和Trim函数对输入的字符串vTeilzeichen进行处理，删除空格并转换为大写。
'接下来，函数检查vTeilzeichen的第一个字符是否有效。如果无效，则返回原始字符串。
'函数继续处理字符串，将其分割成数据包。这里使用了两个循环，第一个循环用于遍历字符串中的每个字符，第二个循环用于处理数字部分。
'如果数字部分的长度大于6位或字母部分的长度大于4位，则返回原始字符串。
'接下来，函数处理索引部分。根据索引中字符的类型（X、Y、Z、W、U），更新sIndex和sIndexNr$变量。
'最后，函数将处理后的结果拼接成一个字符串，并返回。如果结果长度不等于14位，则返回原始字符串。
' 将指定字符串转换为 Eickhoff 子串格式
'2004-02-28 ---------------------------------------------------------
'复制自 gearbox2000DV2-01V1-0 功能 "NCR_TZ
'将指数改为 G
'-------------------------------
'最后更新： 2006-11-27
'重新命名和更改 Excel 函数
'---------------------------------------------------------------------
On Error GoTo Err_NCR_TZ
'------------------------------------------------------------------------------
'Dim EickhoffTZ$
Dim Nr$
Dim ZeichLiVonNr$, ZeichReVonNr$
Dim i As Integer
Dim sIndex$, sIndexNr$
Dim Buchstabe$
Dim Nr_Laenge%
Dim vTeilzeichen_original As Variant '截至 2006-11-27
vTeilzeichen_original = vTeilzeichen
vTeilzeichen = UCase(Trim(vTeilzeichen)) '删除空格 删除开始/结束
'不要删除空格，否则将无法识别所附索引
'------------------1 检查 vSubcharacter 中的字符是否有效
'2006-11-27 新
'vTeilzeichen = WorksheetFunction.Trim(Replace(Replace(vTeilzeichen, ChrW(160), " "), ChrW(12288), " "))
vTeilzeichen = Application.Trim(Replace(Replace(vTeilzeichen, ChrW(160), " "), ChrW(12288), " "))
'2023-10-15 新 去除不间断空格和全角空格，删除中间
Select Case Left(vTeilzeichen, 1)
Case "C", "F", "G", "L", "N", "R", "S", "V"
'o.K.
'取消"B"，增加"V" 2023.10.16
Case Else
TZ_Pruefen = vTeilzeichen_original
GoTo Exit_NCR_TZ 'Ende
End Select
'-------------------------------------------------------------------------
'String in Pakete aufteilen 将字符串分割成数据包
'ZeichLiVonNr$, Nr$, ZeichReVonNr$
'启动
Nr$ = ""
Nr_Laenge% = 0
'-------------------------------------------------------------------------
'Nr 未格式化
For i = 1 To Len(vTeilzeichen)
Buchstabe$ = Mid$(vTeilzeichen, i, 1)
If Not IsNumeric(Buchstabe$) And Nr_Laenge% = 0 Then
ZeichLiVonNr$ = ZeichLiVonNr$ & Buchstabe$
ElseIf Not IsNumeric(Buchstabe$) And Nr_Laenge% > 0 Then
ZeichReVonNr$ = Right$(vTeilzeichen, Len(vTeilzeichen) - (Len(ZeichLiVonNr$) + Len(Nr$)))
Nr_Laenge% = -1
ElseIf IsNumeric(Buchstabe$) And Nr_Laenge% >= 0 Then
Nr$ = Nr$ & Buchstabe$
Nr_Laenge% = Nr_Laenge% + 1
End If
Next i
'------------------------------------------------------------------------------
If Len(Nr$) > 6 Then ' 6 位数字 - 输出零字符串
TZ_Pruefen = vTeilzeichen_original
GoTo Exit_NCR_TZ '结束
End If
If Len(ZeichLiVonNr) > 4 Then
TZ_Pruefen = vTeilzeichen_original
End If
'----------------- 索引中有 1 个字符 ---------------------------
Buchstabe$ = ""
Zeichen_1:
Buchstabe$ = Mid$(UCase(ZeichReVonNr), 1, 1)
If InStr("XYZWU", UCase(Buchstabe$)) > 0 Then
sIndex = Mid$(ZeichReVonNr, 1, 1)
GoTo Zeichen_2
End If
'删除空格
If InStr(Space$(1), Buchstabe$) > 0 Then
ZeichReVonNr = Mid$(ZeichReVonNr, 2)
GoTo Zeichen_1
End If
If InStr("/-.\", Buchstabe$) > 0 Then
ZeichReVonNr = Mid$(ZeichReVonNr, 2)
GoTo Zeichen_1
End If
'移动索引 A
If InStr("ABCDEFGHIJK", Buchstabe$) > 0 Then
ZeichReVonNr = Space$(1) & ZeichReVonNr
sIndex = Space$(1)
End If
'------------- 索引中有 2 个字符 --------------------------------
Zeichen_2:
'28.02.2004 将指数改为 G
Buchstabe$ = Mid$(UCase(ZeichReVonNr), 2, 1)
If InStr("ABCDEFGHIJK", UCase(Buchstabe$)) > 0 Then
If Len(sIndex) = 0 Then
sIndex = Space(1) & Mid$(ZeichReVonNr, 2, 1)
Else
sIndex = sIndex & Mid$(ZeichReVonNr, 2, 1)
End If
GoTo Zeichen_3
End If
'删除空格
If InStr(Space$(1), Buchstabe$) > 0 Then
ZeichReVonNr = Mid$(ZeichReVonNr, 2)
GoTo Zeichen_2
End If
If InStr("/-.", Mid(ZeichReVonNr, 2, 1)) > 0 Then
ZeichReVonNr = Mid$(ZeichReVonNr, 2)
GoTo Zeichen_2
End If
'交换索引
Zeichen_3:
If Len(ZeichReVonNr) >= 3 Then
If InStr("XYZWU", Mid$(UCase(ZeichReVonNr), 3, 1)) > 0 Then
sIndex = Mid$(ZeichReVonNr, 3, 1) & Trim(sIndex)
GoTo Index_Ende
Else
GoTo Index_Ende
End If
End If
'--------------------------------------------------------------------
'IndexNr --------------------------
Index_Ende:
If IsNumeric(Right$(ZeichReVonNr, 1)) Then '没有添加
sIndexNr$ = Right$(ZeichReVonNr, 2)
'如果只指定 1 个数字，则隔离编号
sIndexNr$ = str(ESLIB_Val_aus_String(sIndexNr$))
If IsNumeric(sIndexNr$) Then
sIndexNr$ = Format$(sIndexNr$, "00")
End If
Else
sIndexNr$ = "00"
End If
If Len(sIndex) = 0 Then
sIndex = Space$(2) & sIndexNr$
ElseIf Len(sIndex) = 1 Then
sIndex = sIndex & Space$(1) & sIndexNr$
ElseIf Len(sIndex) = 2 Then
sIndex = sIndex & sIndexNr$
Else
sIndex = sIndex & "!!!!!!!!!!!"
End If
'-----------------------------------------------------------------
TZ_Pruefen = UCase(ZeichLiVonNr$ & Space$(4 - Len(ZeichLiVonNr)) & Format$(Nr, "000000") & sIndex)
If Len(TZ_Pruefen) <> 14 Then
TZ_Pruefen = vTeilzeichen_original
End If
If IsNumeric(TZ_Pruefen) Then
TZ_Pruefen = "'" & TZ_Pruefen
End If
Exit_NCR_TZ:
Exit Function
Err_NCR_TZ:
TZ_Pruefen = vTeilzeichen_original '原稿
'MsgBox Err.描述
Resume Exit_NCR_TZ
End Function
Public Function ESLIB_Val_aus_String(ByVal strZahl As String) As Double
'这段VBA代码定义了一个名为ESLIB_Val_aus_String的公共函数，该函数接受一个字符串参数strZahl，并返回一个双精度浮点数。
'函数的主要目的是从输入的字符串中提取第一个数字，并将其转换为双精度浮点数。
'在处理过程中，函数会将字符串中的点（"."）替换为逗号（","），然后将字符串转换为双精度浮点数。
'如果找不到任何数字，函数将返回0。
'截至 2004-02-28
'隔离从字符串中找到的第一个数字，无论它出现在字符串的哪个位置。
'在这里，一个点被转换为逗号，然后字符串被转换为双数
'类似于 Val 只允许用". "作为逗号，逗号会被忽略，只有
'输出数字的整数部分
'----------------------------------------------------------------------------------------
Dim i As Integer
Dim Nr As Double
Dim strNr$
Dim Buchstabe$
Dim Zahl_gefunden As Boolean
Zahl_gefunden = False
For i = 1 To Len(strZahl)
Buchstabe$ = Mid$(strZahl, i, 1)
If IsNumeric(Buchstabe$) Then
strNr$ = strNr$ & Buchstabe$
Zahl_gefunden = True
Else
'在这里，您必须检查 97 是否接受逗号，还是只接受句号。
'2000 不接受点作为逗号
'If Zahl_gefunden = True And (Buchstabe$ = ",") Then
'如果 Number_found = True 并且 (Letter$ = ",") 然后
' strNr$ = strNr$ & Buchstabe$
If Zahl_gefunden = True And Buchstabe = "." Then
strNr$ = strNr$ & ","
Else
If Zahl_gefunden = True Then
i = Len(strZahl) + 1
End If
End If
End If
Next i
If Len(strNr$) > 0 Then
ESLIB_Val_aus_String = CDbl(strNr$)
Else
ESLIB_Val_aus_String = 0
End If
End Function
'Callback for customButton onAction
Public Sub cBAction1(control As IRibbonControl)
Call TZ_in_Markierung_Pruefen
End Sub
编译错误：
要在64位系统上使用，请检查并更新Declare 语句
将错误处的 “Declare”替换成“Declare PtrSafe” 即可
编译错误：
子过程或函数未定义
ESLIB_Val_aus_String
If Len(Trim(gesM.Cells(i).Value)) <= 18 Then
'将14改为18 2023.10.16
vTeilzeichen = Application.Trim(Replace(Replace(vTeilzeichen, ChrW(160), " "), ChrW(12288), " "))
'2023-10-15 新 去除不间断空格和全角空格，删除中间
Case "C", "F", "G", "L", "N", "R", "S", "V"
'o.K.
'取消"B"，增加"V" 2023.10.16
网友评论