VBA 代码更改为 64 位。宏观因素销售不起作用

Posted 2023-04-13

【中文标题】VBA 代码更改为 64 位。宏观因素销售不起作用

【英文标题】：VBA code change to 64 bit. Macro to factor sales not working

【发布时间】：2018-02-27 05:19:15

【问题描述】：

我继承了一个非常有用的宏，现在它在我们的新 64 位机器上不起作用 - 我已经修改了前面的 PtrSafe 代码，它似乎可以工作，但现在我在下面的宏上遇到了错误，我使用了所有时间。该宏通过将突出显示的单元格值修改为新输入数字的值来工作：该错误似乎突出显示了第一个 = Mid 代码，但它也以黄色突出显示了第一行。

(公共函数 ConcatAll(rngCells As Range, Optional pstrSep$ = "") As String)

任何帮助都会很棒。

Option Explicit

Public Function ConcatAll(rngCells As Range, Optional pstrSep$ = "") As String
  'Concatenates the text values in the specified range
  'Useful when coverting weeks to months

  Dim c As Range
  ConcatAll = ""

  For Each c In rngCells
    If c.Value <> "" Then
      ConcatAll = ConcatAll & pstrSep & c.Value
    End If

  Next

  ConcatAll = Mid(ConcatAll, Len(pstrSep) + 1)

End Function

Public Function ConcatUnique(rngCells As Range, Optional pstrSep$ = "") As String
  'Concatenates the text values in the specified range, only if the value has not been concatenated already
  'Useful when coverting weeks to months

  Dim c As Range, strConcat$
  strConcat = ""

  For Each c In rngCells

    If c.Value <> "" Then
      If InStr(1, strConcat, c.Value) = 0 Then
        strConcat = strConcat & pstrSep & c.Value
      End If

    End If

  Next

  ConcatUnique = Mid(strConcat, Len(pstrSep) + 1)

End Function


Public Function RPad(pstrSubj$, pintLen%, Optional pstrPad$ = " ") As String
'Pads out the right hand end of a given string with another character

  If Len(pstrSubj) >= pintLen Then
    RPad = pstrSubj

  Else
    Dim irpt%, strRes$
    strRes = pstrSubj
    Do Until Len(strRes & pstrPad) > pintLen
      strRes = strRes & pstrPad
    Loop

    If Len(strRes) < pintLen Then
      strRes = strRes & Left(pstrPad, pintLen - Len(strRes))
    End If

    RPad = strRes

  End If

End Function

Public Function LPad(pstrSubj$, pintLen%, Optional pstrLPad$ = " ") As String
'Pads out the left hand end of a given string with another character

  If Len(pstrSubj) >= pintLen Then
    LPad = pstrSubj

  Else
    Dim irpt%, strRes$
    strRes = pstrSubj
    Do Until Len(strRes & pstrLPad) > pintLen
      strRes = pstrLPad & strRes
    Loop

    If Len(strRes) < pintLen Then
      strRes = Left(pstrLPad, pintLen - Len(strRes)) & strRes
    End If

    LPad = strRes

  End If

End Function

Public Function ConcatIf(rngCells As Range, psCond$, Optional pstrSep$ = "", Optional prngVals As Range) As String
  'Concatenates the text values in the specified range if the condition is satisfied
  'Useful when coverting weeks to months

  ConcatIf = ""

  Dim rngVals As Range

  If Not (prngVals Is Nothing) Then
    If RngShapeEq(rngCells, prngVals) = True Then
      Set rngVals = prngVals

    Else
      'Ranges do not equal - return blank
      ConcatIf = "#Error"
      Exit Function

    End If

  Else
    Set rngVals = rngCells

  End If

  Dim iCell%, c As Range
  iCell = 1

  For Each c In rngCells

    If IsError(c) Then
      ConcatIf = "Error in cell " & c.Address
      Exit Function
    ElseIf IsError(rngVals.Cells(iCell)) Then
      ConcatIf = "Error in cell " & rngVals.Cells(iCell).Address
      Exit Function
    Else

      If Application.CountIf(c, psCond) > 0 Then

        ConcatIf = ConcatIf & pstrSep & rngVals.Cells(iCell).Value

      End If
    End If

    iCell = iCell + 1

  Next

  ConcatIf = Mid(ConcatIf, Len(pstrSep) + 1)

End Function

Private Function RngShapeEq(prng1 As Range, prng2 As Range) As Boolean
'Determines if the range shapes are equal

  RngShapeEq = False

  If prng1.Rows.Count = prng2.Rows.Count Then
    If prng1.Columns.Count = prng2.Columns.Count Then

      RngShapeEq = True

    End If
  End If


End Function


Public Function LTrim(pText$, Optional pTrimCh$ = " ") As String
'Trims the left end of the string with pTrimCh

  Dim intTrimChLen%
  intTrimChLen = Len(pTrimCh)

  LTrim = pText

  Do While Left(LTrim, intTrimChLen) = pTrimCh

    LTrim = Mid(LTrim, intTrimChLen + 1)

  Loop

End Function

Public Function RTrim(pText$, Optional pTrimCh$ = " ") As String
'Trims the right end of the string with pTrimCh

  Dim intTrimChLen%
  intTrimChLen = Len(pTrimCh)

  RTrim = pText

  Do While Right(RTrim, intTrimChLen) = pTrimCh

    RTrim = Left(RTrim, Len(RTrim) - intTrimChLen)

  Loop

End Function

【问题讨论】：

试试Public Function ConcatAll(rngCells As Range, Optional pstrSep as String = "") As String

您收到的错误信息是什么？

危险，危险威尔罗宾逊。为什么要定义 RTrim 和 LTrim？为什么要在赋值运算符的右侧使用函数名称？

VBA 中的 PtrSafe？您在此处的所有构造均未设计为在本机 64 位中运行（即不需要 PtrSafe）。

感谢 BruceWayne 和 AJD - 我添加了字符串并删除了一些似乎有效的旧代码。我在这方面完全是新手，并且如前所述，宏是很久以前继承和构建的。如果有人能解决这个问题，我还有另一个会引起我的问​​题吗？它的功能是将二维表转换为新工作表上的一维表。对于将日期作为列标题的表很有用。从选择的第一列的第一个左边的单元格开始。

【参考方案1】：

我看到的直接问题是：

Public Function ConcatAll(rngCells As Range, Optional pstrSep$ = "") As String
  'Concatenates the text values in the specified range
  'Useful when coverting weeks to months
  Dim c As Range
  ConcatAll = ""
  For Each c In rngCells
    If c.Value <> "" Then
      ConcatAll = ConcatAll & pstrSep & c.Value ' *** Problem Here
    End If
  Next
  ConcatAll = Mid(ConcatAll, Len(pstrSep) + 1) ' Problem Here
End Function

右侧对ConcatAll 的调用期望递归调用函数。 VBA IDE 会将其识别为格式错误的代码并将停止，这也解释了为什么它以黄色突出显示该行。使用一个临时变量，然后在 Function 的末尾赋值给 ConcatAll。

检查所有剩余的代码，因为您自始至终都重复了这个错误。

此外，为什么要在解释代码中重新定义本机 RTrim 和 LTrim 函数？ VBA 不太适合重载。至少给它们一些其他名称以表明它们是自定义函数。

在LPad 中，您声明了irpt，但您没有使用它。

你声明了很多整数。在这个时代，至少使用Long！或者，如果您真的认为空间是个问题，您可以使用Short。