vba子程序在一張紙上工作，但不在另一張紙上

Question

我正試圖在兩張單獨的“Alpha Roster”和“Paid”上清理名字。 Alpha Roster由其他人更新，付費是我付費的主跟蹤器。 我有一個名為“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

我讀到了select和activate之間的區別。 正如您所看到的，在CleanUpPaid中，我嘗試了幾種不同的方法使付費工作表成為活動工作表，但在工作表中似乎沒有像Alpha Roster中那樣發生任何事情。

Answer 1

您只處理Worksheets("Paid")上的一個單元格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

---

我的答案如何將每個字母的單詞變成大寫字母而不是字母“of”，“and”，“it”，“for”？ 將為您糾正大寫。

我在文章標題中使用了“資本化規則”作為創建資本化例外列表的參考。

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