vba 子例程在一张纸上工作，但不在另一张纸上工作

Question

我正在尝试清理“Alpha Roster”和“Paid”两张单独的表格上的姓名。 Alpha Roster 由其他人更新，Paid 是我的主要跟踪器，用于跟踪谁已付费。我有一个名为“MakeProper”的函数，它可以很好地对 Alpha Roster 进行更正，但由于某种原因，它没有对 Paid 进行任何更正。两张表的设置相同。

Sub CleanUpPaid()

    Sheets("Paid").Activate
    Sheets("Paid").Select
    Range("A2").Select
    MakeProper

End Sub

Sub MakeProper()
  Dim rngSrc As Range
  Dim lMax As Long, lCtr As Long

  Set rngSrc = ActiveSheet.Range(ActiveWindow.Selection.Address)
  lMax = rngSrc.Cells.Count

  ' clean up Sponsor's Names
  For lCtr = 3 To lMax
    If Not rngSrc.Cells(lCtr, 1).HasFormula And _
            rngSrc.Cells(lCtr, 1) <> "CMC" Then
        rngSrc.Cells(lCtr, 1) = MakeBetterProper(rngSrc.Cells(lCtr, 1))
    End If

  ' clean up Guest's Names
    If Not rngSrc.Cells(lCtr, 7).HasFormula Then
        rngSrc.Cells(lCtr, 7) = MakeBetterProper(rngSrc.Cells(lCtr, 7))
    End If

  Next lCtr
  'MsgBox ("Make Proper " & ActiveSheet.Name)
End Sub

Function MakeBetterProper(ByVal ref As Range) As String
  Dim vaArray As Variant
  Dim c As String
  Dim i As Integer
  Dim J As Integer
  Dim vaLCase As Variant
  Dim str As String

  ' Array contains terms that should be lower case
  vaLCase = Array("CMC", "II", "II,", "III", "III,")

  ref.Replace what:=",", Replacement:=", "
  ref.Replace what:=",  ", Replacement:=", "
  ref.Replace what:="-", Replacement:=" - "
  c = StrConv(ref, 3)

  'split the words into an array
  vaArray = Split(c, " ")

  For i = (LBound(vaArray) + 1) To UBound(vaArray)
    For J = LBound(vaLCase) To UBound(vaLCase)
        ' compare each word in the cell against the
        ' list of words to remain lowercase. If the
        ' Upper versions match then replace the
        ' cell word with the lowercase version.
        If UCase(vaArray(i)) = UCase(vaLCase(J)) Then
            vaArray(i) = vaLCase(J)
        End If
    Next J
  Next i

' rebuild the sentence
  str = ""
  For i = LBound(vaArray) To UBound(vaArray)
    str = str & " " & vaArray(i)
    str = Replace(str, " - ", "-")
    str = Replace(str, "J'q", "J'Q")
    str = Replace(str, "Jr", "Jr.")
    str = Replace(str, "Jr..", "Jr.")
    str = Replace(str, "(Jr.)", "Jr.")
    str = Replace(str, "Sr", "Sr.")
    str = Replace(str, "Sr..", "Sr.")
  Next i

  MakeBetterProper = Trim(str)

End Function

我阅读了选择和激活之间的区别。如您所见，在 CleanUpPaid 中，我尝试了几种不同的方法来使付费工作表成为活动工作表，但工作表上似乎没有像在 Alpha Roster 中那样发生任何事情。

Answer 1

您只处理Worksheets("Paid") 上的一个单元格，即Range("A2")。您可以删除 Set rngSrc = ActiveSheet.Range(ActiveWindow.Selection.Address) 并仅使用 Selection 它返回一个范围对象。

假设您要处理 A 列和 G 列中的单元格。我正在使用我的函数 TitleCase 来更正大写，但如果您愿意，可以替换为 MakeBetterProper。

---

Sub FixNames()
    Application.ScreenUpdating = False

    Dim ws As Worksheet
    Dim c As Range

    For Each ws In Worksheets(Array("Alpha Roster", "Paid"))
        With ws
            For Each c In Intersect(.Columns(1), .UsedRange)

                If Not c.HasFormula And c.Value <> "CMC" Then c.Value = TitleCase(c.text)

            Next

            For Each c In Intersect(.Columns(7), .UsedRange)

                If Not c.HasFormula Then c.Value = TitleCase(c.text)

            Next

        End With

    Next

    Application.ScreenUpdating = True
End Sub

---

我对@9​​87654321@ 的回答将为您更正大写。

我使用Rules for Capitalization in Titles of Articles 作为参考来创建大写例外列表。

Function TitleCase 使用WorksheetFunction.ProperCase 预处理文本。出于这个原因，我为收缩设置了一个例外，因为WorksheetFunction.ProperCase 不正确地大写了它们。

每个句子中的第一个单词和双引号后的第一个单词将保持大写。标点符号也处理得当。

---

Function TitleCase(text As String) As String
    Dim doc
    Dim sentence, word, w
    Dim i As Long, j As Integer
    Dim arrLowerCaseWords

    arrLowerCaseWords = Array("a", "an", "and", "as", "at", "but", "by", "for", "in", "of", "on", "or", "the", "to", "up", "nor", "it", "am", "is")

    text = WorksheetFunction.Proper(text)

    Set doc = CreateObject("Word.Document")
    doc.Range.text = text

    For Each sentence In doc.Sentences
        For i = 2 To sentence.Words.Count
            If sentence.Words.Item(i - 1) <> """" Then
                Set w = sentence.Words.Item(i)
                For Each word In arrLowerCaseWords
                    If LCase(Trim(w)) = word Then
                        w.text = LCase(w.text)
                    End If

                    j = InStr(w.text, "'")

                    If j Then w.text = Left(w.text, j) & LCase(Right(w.text, Len(w.text) - j))

                Next
            End If
        Next
    Next

    TitleCase = doc.Range.text

    doc.Close False
    Set doc = Nothing
End Function