Range.Charactersオブジェクトがループ内で期待通りに機能しない

Question

以下は、進行状況インジケータを作成するExcel VBAのプログラムです。私はできるだけシンプルな進捗インジケータを作ろうとしましたが、それでもまだユニコード文字を使って優雅に見えます：full blockとthin space。

私は、進行状況インジケータが フルブロックは常に緑色であり、割合番号は常に青色のプログラム中でこの

のように見えるしたいのですが

Private Sub Play_Click() 
Dim iCounter As Long, iRow As Long, nRow As Long, _ 
    Block As String, Progress As Long, iChar As Long 

Columns(1).ClearContents 

With Cells(2, 4) 
    .ClearContents 
    .Font.Color = vbBlue 
    nRow = 100 

    For iRow = 1 To nRow 
     For iCounter = 1 To 100 
      Cells(iRow, 1) = iCounter 
     Next 

     Progress = Int(iRow/10) 
     If Progress = iRow/10 Then 
      Block = Block & ChrW(9608) & ChrW(8201) 
      '------------------ 
      'Option statements 
      '------------------ 
     End If 

     .Value = Block & " " & iRow & " %" 
    Next 
End With 
End Sub 

を実行しています。しかし、

オプションこれら三つのオプション・ステートメントを使用して1

.Characters(, 2 * Progress - 1).Font.Color = vbGreen 

オプション2

 For iChar = 1 To Len(.Value) 
      If Mid$(Text, iChar, 1) = ChrW(9608) Then 
       .Characters(iChar, 1).Font.Color = vbGreen 
      End If 
     Next 

オプション3

GreenBlue 2 * Progress - 1 

--------------------- 

Sub GreenBlue(GreenPart As Integer) 

Select Case GreenPart 
    Case 1 To 19 
     Cells(2, 4).Characters(, GreenPart).Font.Color = vbGreen 
End Select 

End Sub 

は、私が最初の写真のような出力を得るための正しい方法は何ですか次の出力

を取得保管しましたか？

Answer 1

セルの値を置き換えるたびに、新しいコンテンツはすべて置換される最初の文字からフォーマットされます。そのため、コンテンツ全体が緑色になります。必要に応じて最初に色を青に戻す必要があります数字部分が青色になります

Private Sub Play_Click() 
Dim iCounter As Long, iRow As Long, nRow As Long, _ 
    Block As String, Progress As Long, iChar As Long, x As Long 

Columns(1).ClearContents 

With Cells(2, 4) 
    .ClearContents 
    .Font.Color = vbBlue 
    nRow = 100 

    For iRow = 1 To nRow 
     For iCounter = 1 To 100 
      Cells(iRow, 1) = iCounter 
     Next 

     Progress = Int(iRow/10) 
     If Progress = iRow/10 Then 
      Block = Block & ChrW(9608) & ChrW(8201) 
     End If 


     Application.ScreenUpdating = False 'reduce flashing during update 
     .Value = Block & " " & iRow & " %" 
     .Font.Color = vbBlue 
     If Len(Block) > 0 Then 
      .Characters(1, InStr(.Value, " ")).Font.Color = vbGreen 
     End If 
     Application.ScreenUpdating = True 

     'add some delay... 
     For x = 1 To 1000 
      DoEvents 
     Next x 


    Next 
End With 
End Sub