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

Posted

技术标签:

【中文标题】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。

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

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

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

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

【讨论】:

以上是关于VBA 代码更改为 64 位。宏观因素销售不起作用的主要内容,如果未能解决你的问题,请参考以下文章

以编程方式访问 VBA 设置字体/大小不起作用

VBA CreateObject 无法在 64 位 Windows 上创建 ActiveX 组件

将数字更改为不起作用的单词的代码

将局部变量更改为全局变量不起作用

将属性更改为只读不起作用

使用EXCEL vba下载文件时出现问题