Perguntas[vba](computer)

Tenho um código VBA para converter números de moeda em texto. MAS, não está gramaticalmente correto.

Exemplo: eu digito 113.729 e o valor é convertido em Cento e Treze Mil Setecentos e Vinte e Nove Dólares.

O que eu QUERO que pareça é: Cento e Treze Mil, Setecentos e Vinte e Nove Dólares. E o mesmo se for para milhões. 1.113.729 - Um Milhão, Treze Mil, Setecentos e Vinte e Nove Dólares.

Isso é possível?

  '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```

Quero executar o RegEx no código SQL completo de centenas de consultas do MS Access que faço um loop com o VBA em todos os bancos de dados do Access que podem ser encontrados em uma pasta.

O atributo "SQL" do objeto de consulta já vem como uma String, e se você copiar o código da janela Locals para algum editor, ele será cortado em 255 caracteres:

Por isso:

Aqui está o código até agora, embora esta pergunta também possa ser respondida sem código, e uma resposta não precisa usar o exemplo de código:

Para o padrão RegEx, consulte também MS Access VBA não pode lidar com lookarounds. É necessária uma correspondência dupla de RegEx antecipada/tardia. "Erro em tempo de execução '5017': erro definido pelo aplicativo ou definido pelo objeto" - Stack Overflow com um padrão Regex que também funcionaria se houvesse apenas uma coluna ou se a coluna "erro" fosse a primeira coluna, ou se o coluna vizinha não termina com AS .... Lá, o código apenas procura a vírgula antes do AS .... Isso não ajudará se você tiver vírgulas dentro da definição da coluna (que eu não tenho).

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

Portanto, este guia funciona, mas funciona apenas para códigos SQL mais curtos: Obtendo string sql de uma consulta :

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

Como obtenho o código SQL completo que pode ter mais de 255 caracteres de uma variável String, percorrendo todas as consultas e todos os bancos de dados de um diretório? Isso não precisa ser respondido em VBA, mas seria a primeira escolha.

Embora eu tenha alterado algum código VBA no MS Access para preencher novas colunas que adicionei a uma tabela do Access, tive dificuldades com uma instância travada que permaneceu aberta mesmo se eu clicasse em "Fechar"/ X.

Segui o primeiro hit de pesquisa [Acesso] Você não pode modificar a estrutura da tabela porque ela já está em uso por outra pessoa ou processo :

Tente reiniciar, se ainda não o fez. Se isso não funcionar, tente copiar o banco de dados e tente editar a cópia. Se funcionar, exclua o original e renomeie a cópia como era.

Eu queria evitar uma reinicialização completa para fazer uma cópia do arquivo e trabalhar nisso. O bom é que eu estava em uma nova instância em um novo arquivo, e também pude fechá-lo novamente. A instância estava funcionando. Mas quando adicionei uma nova coluna na tabela e tentei preenchê-la, me deparei com o erro:

Não é possível modificar a estrutura da tabela "xyz", pois ela já está em uso por outra pessoa ou processo.

E mais, o código fazia alguma coisa, mas não preenchia a tabela em questão, funcionava em outra tabela oculta, ao que parecia. Achei que isso viria da falha, de modo que a instância travada dominasse aquela em que eu estava trabalhando.

O código:

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

O que deve ser feito se você se deparar com isso?

Eu pedi em outro fórum para modificar um código VBA, um cara chamado « Harun24hr » me ajudou com um código (muito obrigado a ele), mas não consegui fazer com o segundo.

O código calcula a chave de um número de conta bancária, mas quero modificá-lo para que o código pegue 10 números da direita para calcular a chave correspondente.

Por exemplo, se o número for: 6465981, o código levará tudo em consideração, pois tem 7 números. Se o número for 007999990006465981, será necessário 0006465981 para calcular a chave.

O código é:

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

Eu tenho um intervalo de colunas com células em branco. Estou tentando copiar se alguma dessas células contém um texto. Para isso, escrevi o código a seguir, que funciona bem para a primeira linha. Como repetir isso para cada linha até a última linha usada?

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

Eu fiz essa pergunta "ontem" no Graphic Design SE, mas fui informado de que o SuperUser seria mais útil no que estou tentando realizar. Minha dúvida é sobre o uso de linhas de base, mas lembre-se de que tenho uma cópia do MSOffice 2016 Home & Student.

Estou tentando escrever o VBA para realizar o ajuste de caracteres individuais em todo o meu documento:

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

A intenção disso, para começar, é fazer com que um documento pareça ter sido digitado em uma máquina de escrever. Eu já tenho uma fonte monoespaçada para trabalhar, mas com a maneira como o MSWord analisa isso torna os valores de linha de base aleatórios -1, 0 ou 1. Defini-los como valores decimais para tornar a mudança de linha de base menos dramática aparentemente trunca para apenas zero e não muda absolutamente nada. O código analisa cada caractere do documento, visto pelo histórico de edição ao clicar em 'Desfazer', mas não há diferença visível. Como devo corrigir isso para o meu projeto ultra específico pretendido?

Eu tenho valor como "VERDADEIRO" nas colunas B a H. Quero que minha macro retorne "FALSO" na coluna A se alguma célula no intervalo B:H contiver "FALSO" senão "VERDADEIRO". E faça isso até a última linha preenchida. Qualquer ajuda é apreciada!

Eu tentei o código abaixo que está funcionando para uma linha, mas como fazer isso para todas as linhas preenchidas?

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

Existe um banco de dados do MS Access. Às vezes, há erros de pop-ups: "O valor digitado não é válido para este campo" e, em seguida, um erro de macro. Mas tudo bem, basta clicar em "Parar todas as macros" e tentar novamente.

Mas com o MS Access 2016 Runtime é diferente. O banco de dados simplesmente fecha. Como fazê-lo se comportar da mesma forma que o MS Access 2016 completo? Não quero que o banco de dados seja fechado quando houver um pequeno erro.

Alguém pode me informar onde está o erro no código abaixo?

Será que a lista é muito longa? Não sei por que estou recebendo o erro de sintaxe.
Grato por qualquer ajuda que você possa fornecer.

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

Eu quero imprimir o número da linha na planilha DataSetcom vba:

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