问题[vba](computer)

我有一个 VBA 代码，用于将货币数字转换为文本。但是，它在语法上不正确。

例如：我输入 113,729，转换为十万一千三千七百二十九美元。

我希望它看起来像这样：十一万三千七百二十九美元。如果是百万，也是一样。1,113,729 - 一百一万三千七百二十九美元。

这可能吗？

  'Main Function
  Function SpellNumber(ByVal MyNumber)
      Dim Dollars, Cents, Temp
      Dim DecimalPlace, Count
      ReDim Place(9) As String
      Place(2) = " Thousand "
      Place(3) = " Million "
      Place(4) = " Billion "
      Place(5) = " Trillion "

      MyNumber = Trim(Str(MyNumber))
      DecimalPlace = InStr(MyNumber, ".")
      If DecimalPlace > 0 Then
          Cents = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & _
                    "00", 2))
          MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
      End If
      Count = 1
      Do While MyNumber <> ""
          Temp = GetHundreds(Right(MyNumber, 3))
          If Temp <> "" Then Dollars = Temp & Place(Count) & Dollars
          If Len(MyNumber) > 3 Then
              MyNumber = Left(MyNumber, Len(MyNumber) - 3)
          Else
              MyNumber = ""
          End If
          Count = Count + 1
      Loop
      Select Case Dollars
          Case ""
              Dollars = "No Dollars"
          Case "One"
              Dollars = "One Dollar"
           Case Else
              Dollars = Dollars & " Dollars"
      End Select
      Select Case Cents
          Case ""
              Cents = " and No Cents"
          Case "One"
              Cents = " and One Cent"
                Case Else
              Cents = " and " & Cents & " Cents"
      End Select
      SpellNumber = Dollars & Cents
  End Function

  Function GetHundreds(ByVal MyNumber)
      Dim Result As String
      If Val(MyNumber) = 0 Then Exit Function
      MyNumber = Right("000" & MyNumber, 3)
      ' Convert the hundreds place.
      If Mid(MyNumber, 1, 1) <> "0" Then
          Result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred "
      End If
      ' Convert the tens and ones place.
      If Mid(MyNumber, 2, 1) <> "0" Then
          Result = Result & GetTens(Mid(MyNumber, 2))
      Else
          Result = Result & GetDigit(Mid(MyNumber, 3))
      End If
      GetHundreds = Result
  End Function

  Function GetTens(TensText)
      Dim Result As String
      Result = "" ' Null out the temporary function value.
      If Val(Left(TensText, 1)) = 1 Then   ' If value between 10-19&hellip;
          Select Case Val(TensText)
              Case 10: Result = "Ten"
              Case 11: Result = "Eleven"
              Case 12: Result = "Twelve"
              Case 13: Result = "Thirteen"
              Case 14: Result = "Fourteen"
              Case 15: Result = "Fifteen"
              Case 16: Result = "Sixteen"
              Case 17: Result = "Seventeen"
              Case 18: Result = "Eighteen"
              Case 19: Result = "Nineteen"
              Case Else
          End Select
      Else ' If value between 20-99&hellip;
          Select Case Val(Left(TensText, 1))
              Case 2: Result = "Twenty "
              Case 3: Result = "Thirty "
              Case 4: Result = "Forty "
              Case 5: Result = "Fifty "
              Case 6: Result = "Sixty "
              Case 7: Result = "Seventy "
              Case 8: Result = "Eighty "
              Case 9: Result = "Ninety "
              Case Else
          End Select
          Result = Result & GetDigit _
              (Right(TensText, 1))  ' Retrieve ones place.
      End If
      GetTens = Result
  End Function

  Function GetDigit(Digit)
      Select Case Val(Digit)
          Case 1: GetDigit = "One"
          Case 2: GetDigit = "Two"
          Case 3: GetDigit = "Three"
          Case 4: GetDigit = "Four"
          Case 5: GetDigit = "Five"
          Case 6: GetDigit = "Six"
          Case 7: GetDigit = "Seven"
          Case 8: GetDigit = "Eight"
          Case 9: GetDigit = "Nine"
          Case Else: GetDigit = ""
      End Select
  End Function```

我想对数百个 MS Access 查询的完整 SQL 代码运行 RegEx，我使用 VBA 对文件夹中可以找到的所有 Access 数据库进行循环。

查询对象的“SQL”属性已经作为字符串出现，如果将代码从本地窗口复制到某个编辑器，它已被削减为 255 个字符：

因此：

这是到目前为止的代码，尽管这个问题也可以在没有代码的情况下得到回答，并且答案不需要使用代码示例：

有关 RegEx 模式，另请参阅MS Access VBA 无法处理环视。需要双早/晚正则表达式匹配。“运行时错误‘5017’：应用程序定义或对象定义的错误” -与正则表达式模式堆栈溢出，如果只有一列或“错误”列是第一列，或者如果相邻列不以 结尾AS ...。在那里，代码只是搜索 之前的逗号AS ...。如果列定义中有逗号（我没有），这将无济于事。

Option Compare Database

Function extractErrorColumnAndWhereCondition(obj_SQL As String) As Variant
    Dim error As String
    Dim whereCondition As String
    Dim regex As Object
    Dim matches As Object
    Dim regexPattern As String
    
    regexPattern = "AS (\w+)(?: AS error)? INTO (\w+) FROM.*WHERE(.*)"
    
    Set regex = CreateObject("VBScript.RegExp")
    With regex
        .Global = False
        .MultiLine = True
        .IgnoreCase = True
        .Pattern = regexPattern
    End With
    
    Set matches = regex.Execute(obj_SQL)
    
    If matches.Count > 0 Then
        error = matches(0).SubMatches(0)
        whereCondition = matches(0).SubMatches(2)
        extractErrorColumnAndWhereCondition = Array(error, whereCondition)
    Else
        extractErrorColumnAndWhereCondition = Array("", "")
    End If
End Function

Sub DurchsucheAccessfile_Nameen()
    Dim fso As Object
    Dim fld As Object
    Dim db As Object
    Dim rs As Object
    Dim array_output As Variant
    Dim obj_SQL As String
    
    Set fso = CreateObject("Scripting.FileSystemObject")
'    Set fld = fso.GetFolder(".\my_folder")
    Set fld = fso.GetFolder("K:\MS Access\my_folder")
    
    Dim targetDB As Object
    Dim object_type As String
    Dim object_kind As String
'    Set targetDB = Application.DBEngine.Workspaces(0).OpenDatabase(".\my_file.accdb")
    Set targetDB = Application.DBEngine.Workspaces(0).OpenDatabase("K:\MS Access\my_file.accdb")
    
    For Each file In fld.Files
        file_Name = file.Name
        If Right(file_Name, 4) = ".mdb" Or Right(file_Name, 6) = ".accdb" Then
            Set db = Application.DBEngine.Workspaces(0).OpenDatabase(file.Path)
            
            For Each obj In db.TableDefs
                obj_Name = obj.Name
                If Left(obj_Name, 4) <> "MSys" And Left(obj_Name, 1) <> "~" Then
                    Set rs = targetDB.OpenRecordset("my_file")
                    rs.AddNew
                    rs("file_Name").Value = file_Name
                    rs("obj_Name").Value = obj_Name
                    rs("LastUpdated").Value = obj.LastUpdated
                    If InStr(1, obj_Name, "Formular", vbTextCompare) Then
                        object_type = "Formular"
                    ElseIf InStr(1, obj_Name, "TAB", vbTextCompare) Or InStr(1, obj_Name, "dbo_", vbTextCompare) Then
                        object_type = "Table"
                    Else
                        object_type = "Unknown"
                    End If
                    rs("object_type").Value = object_type
                    If object_type = "Table" Then
                        If InStr(1, obj_Name, "_v_", vbTextCompare) Then
                            object_kind = "Linked View"
                        ElseIf InStr(1, obj_Name, "_tbl", vbTextCompare) Then
                            object_kind = "Linked Table"
                        Else
                            object_kind = "loaded"
                        End If
                    ElseIf object_type = "Formular" Then
                        object_kind = "Formular"
                    Else
                        object_kind = "Unknown"
                    End If
                    rs("object_kind").Value = object_kind
                    rs("SourceTableName").Value = obj.SourceTableName
                    rs.Update
                End If
            Next obj
            
            
            For Each obj In db.QueryDefs
                obj_Name = obj.Name
                If Left(obj_Name, 1) <> "~" Then
                    rs.AddNew
                    rs("file_Name").Value = file_Name
                    rs("obj_Name").Value = obj_Name
                    rs("LastUpdated").Value = obj.LastUpdated
                    rs("object_type").Value = "Abfrage"
                    obj_SQL = obj.SQL
                    If InStr(1, obj_SQL, "into ", vbTextCompare) Then
                        object_kind = "select into"
                    Else
                        object_kind = "select"
                    End If
                    rs("object_kind").Value = object_kind
                    rs("Query_SQL").Value = obj_SQL
                    array_output = extractErrorColumnAndWhereCondition(obj_SQL)
                    If IsArray(array_output) Then
                        rs("error").Value = array_output(0)
                        rs("Where_Condition").Value = array_output(1)
                    End If
                    rs.Update
                End If
            Next obj
            
            db.Close
        End If
    Next file
    
    targetDB.Close
End Sub

因此，本指南有效，但仅适用于较短的 SQL 代码：从查询中获取 sql 字符串：

Private Function GetQuerySQL(MyQueryName as String) as String
Dim QD As DAO.QueryDef
 
Set QD = CurrentDb.QueryDefs(MyQueryName)
GetQuerySQL=QD.SQL
 
End Function

如何获取比字符串变量的 255 个字符长的完整 SQL 代码，并循环遍历目录的所有查询和所有数据库？这个问题不必在 VBA 中回答，但它是首选。

虽然我在 MS Access 中更改了一些 VBA 代码来填充添加到 Access 表中的新列，但我还是遇到了一个崩溃的实例，即使我单击“关闭”/，该实例仍保持打开状态X。

我按照第一个搜索命中[Access] 你无法修改表的结构，因为它已被其他人或进程使用：

如果尚未重新启动，请尝试重新启动。如果这不起作用，请尝试复制数据库，然后尝试编辑副本。如果有效，请删除原始文件并将副本重命名为原来的名称。

我想避免完全重新启动，因此我制作了该文件的副本并在其中工作。好处是我处于新文件的新实例中，而且我还可以再次关闭它。该实例正在运行。但是当我在表中添加新列并尝试填充它时，我遇到了错误：

您无法修改表“xyz”的结构，因为它已被其他人或进程使用。

更重要的是，代码做了一些事情，但它没有填充手头的表，它似乎在另一个隐藏的表上工作。我认为这可能是由于崩溃造成的，因此崩溃的实例主导了我正在处理的实例。

代码：

Option Compare Database

Sub DurchsucheAccessDatenbanken()
    Dim fso As Object
    Dim fld As Object
    Dim db As Object
    Dim rs As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fld = fso.GetFolder("K:\MS Access\my_folder")
    
    Dim targetDB As Object
    Dim Objekttyp As String
    Dim Objektart As String
    Set targetDB = Application.DBEngine.Workspaces(0).OpenDatabase("K:\MS Access\my_file.accdb")
    
    For Each file In fld.Files
        file_Name = file.Name
        If Right(file_Name, 4) = ".mdb" Or Right(file_Name, 6) = ".accdb" Then
            Set db = Application.DBEngine.Workspaces(0).OpenDatabase(file.Path)
            
            ' Hier kannst du den Code ergänzen, um die Objekten der Datenbank auszulesen
            For Each obj In db.TableDefs
                obj_Name = obj.Name
                If Left(obj_Name, 4) <> "MSys" And Left(obj_Name, 1) <> "~" Then
                    Set rs = targetDB.OpenRecordset("my_table")
                    rs.AddNew
                    rs("Database").Value = file_Name
                    rs("obj_Name").Value = obj_Name
                    rs("LastUpdated").Value = obj.LastUpdated
                    rs.Update
                End If
            Next obj
    Next file
    
    targetDB.Close
End Sub

如果遇到这种情况应该怎么办？

我在另一个论坛上请求修改 VBA 代码，一个名叫“Harun24hr”的人帮我修改了一个代码（非常感谢他），但我没能完成第二个代码。

该代码计算银行帐号的密钥，但我想对其进行修改，以便代码从右侧取 10 个数字来计算相应的密钥。

例如，如果号码是：6465981，则代码将全部考虑在内，因为它有 7 个数字长。如果数字是007999990006465981，则需要0006465981来计算密钥。

代码是：

Public Function RIP(Cle_RIP As String) As String

If Cle_RIP = "" Then
   Cle_RIP = 0
End If

RIP = Cle_RIP * 100
RIP = RIP - 97 * Int(RIP / 97)
RIP = RIP + 85

If RIP < 97 Then
   RIP = RIP + 97
Else
   RIP = RIP
End If

RIP = RIP - 97
RIP = 97 - RIP

If RIP < 10 Then
   RIP = "0" & RIP
Else
   RIP = RIP
End If
End Function

我有一系列列，其中大部分是空白单元格。我正在尝试复制这些单元格是否包含文本。为此，我编写了以下代码，该代码适用于第一行。如何对每一行重复此操作，直到最后使用的行？

Dim SrchRng As Range, cel As Range
Set SrchRng = Sheet1.Range("BI2:CZ2")
        For Each cel In SrchRng
        If cel.Value <> "" Then
        Sheet1.Range("AH2").Value = cel.Value
    End If
Next cel

我“昨天”在 Graphic Design SE 上问过这个问题，但有人提示我超级用户对于我想要完成的任务会更有用。我的问题是关于基线的使用，但请记住，我有一份 MSOffice 2016 Home & Student。

我正在尝试编写 VBA 在整个文档中执行单个字符调整：

Sub RandomizeBaseline()
    Dim rng As Range
    Dim char As Variant
    Dim baseline As Double
    Set rng = ActiveDocument.Range
    For Each char In rng.Characters
        baseline = Rnd() * 2 - 1
        char.Font.Position = baseline
    Next char
End Sub

这样做的最初目的是使文档看起来就像是在打字机上打字的一样。我已经有了一个可以使用的等宽字体，但是 MSWord 解析的方式使随机基线值变为 -1、0 或 1。将这些值设置为十进制值可以使基线偏移不那么剧烈，显然会截断为仅零并且根本不会改变任何东西。该代码确实解析了文档中的每个字符，单击“撤消”时可以从编辑历史记录中看到，但没有明显的差异。我应该如何为我想要的超具体项目解决这个问题？

我在 B 到 H 列中的值为“TRUE”。如果 B:H 范围内的任何单元格包含“FALSE”，否则“TRUE”，我希望我的宏在 A 列中返回“FALSE”。直到最后一行填满为止。任何帮助表示赞赏！

我尝试了下面的代码，该代码适用于一行，但如何对所有填充的行执行此操作？

Sub Test2()

Dim foundRng As Range

Set foundRng = Range("B2:H2").Find("FALSE")

If foundRng Is Nothing Then
    Range("A2").Value = "TRUE"
Else
    Range("A2").Value = "FALSE"
End If
End Sub

有一个 MS Access 数据库。有时会出现弹出错误：“您输入的值不适用于此字段”，然后出现宏错误。但没关系，我只需单击“停止所有宏”并再试一次。

但对于 MS Access 2016 Runtime，情况就不同了。数据库刚刚关闭。如何使它的行为方式与完整的 MS Access 2016 相同？我不想在出现小错误时关闭数据库。

有人可以让我知道下面代码中的错误在哪里吗？

是不是名单​​太长了？我不知道为什么会出现语法错误。
感谢您提供的任何帮助。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim tabArray As Variant
    Dim i As Long
    tabArray = Array("B3","B4","G3","F7","H7","I7","J7","F8","H8","I8","J8","F9","H9","I9","J9","F10","H10","I10","J10","F11","H11","I11","J11","F12","H12","I12","J12","F13","H13","I13","J13","F14","H14","I14","J14","F15","H15","I15","J15","F19,"I19","C23","F23","C27","C29","C36","F37","I36","C37","C38","C40","C41","C42","G46","H46","G47","H47","G48","H48","C77","C80","C85","D85","C86","D86","C87","D87","C89","D89","C90","D90","C91","D91","C92","D92","C93","D93","C94","D94","C95","D95","C96","D96","G90","J90","G91","J91","G92","J92","G93","J93","G94","J94","G95","J95","C99","C103","C104","C107","C111","C115","D115","H115","C116","D116","H116","C117","D117","H117","C118","D118","H118","C119","D119","H119","A124","A125","A126","A127","A128","A129","A130","A131","A132","A133","A134","A135","A136","A137")
    Application.ScreenUpdating = False
    For i = LBound(tabArray) To UBound(tabArray)
        If tabArray(i) = Target.Address(0, 0) Then
            If i = UBound(tabArray) Then
                Me.Range(tabArray(LBound(tabArray))).Select
            Else
                Me.Range(tabArray(i + 1)).Select
            End If
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

我想在工作表中打印行DataSet号vba：

Sub cal()
    Dim x As Integer
    Worksheets("DataSet").Activate
    x = ActiveSheet.Range("A65535").End(xlUp).Row
    Debug.Print x
End Sub