Question

我试图在两张单独的床单上清理姓名＆＃34; Alpha Roster＆＃34;和＆＃34;付费＆＃34;。 Alpha Roster由其他人更新，付费是我付费的主跟踪器。我有一个名为＆＃34; MakeProper＆＃34;在Alpha名册上进行更正时效果相当不错，但由于某些原因，不会对付费进行任何更正。两张纸都设置相同。

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")上的一个单元格，即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

我对How to make every letter of word into caps but not for letter “of”, “and”, “it”, “for” ?.的回答会纠正您的大写字母。

我使用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

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

1 个答案: