vbaサブルーチンは1つのシートでは動作しますが、別のシートでは動作しません

Question

2つのシート「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")には1つのセルしか処理されておらず、それは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 TitleCaseWorksheetFunction.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