VBA 文字を数値として計算

Question

実現したいこと

転記元表から転記先表へ以下条件をもとに計算し記入するVBAを作成したくご協力のほどよろしくお願いします。
＜詳細＞
転記先Noと合致する転記元表Noを以下条件のもと集約し計算して記入
例1.青木さん(V列)の場合、No1.A×12＝2点×12＝24点、記入結果（平均値）＝24点/12行＝2点、
よって転記先セル（E7）へAと記入※条件2より
例2.井川さん(W列)の場合、No2.A×1+B×1+C×1＝2点+1点+0.5点=3.5点、記入結果（平均値）
=3.5点/3行=1.2(1.166..)点、よって転記先セル（F8）へBと記入
＜条件＞
1.ランクと点数の関係
A:2点
B:1点
C:0.5点
空白:0点
2.ランク算出式
2点以上はA
1点以上2点未満はB
0.5点以上1点未満はC
0点以上0.5点未満は空白
3.空白は0点としてカウント
4.作業者、Noとも場所は固定になります。
●対象ｅｘｃｅｌの配置

●転記先

●転記元_1

●転記元_2

●転記元_3

発生している問題・エラーメッセージ

思考錯誤しながら現コードにたどりついたのですが、以下壁にあたりました。
①該当Noを集約した計算が出来ませんでした。
②作業者、Noの組み合わせ数が多いため、私のやり方だと処理に時間がかかると考えた為、処理スピードもあげる方法も教えていただきたいです。

該当のソースコード

Sub 作業者能力計算()
Dim TF As Workbook 'VBA搭載ファイル宣言
Set TF = ThisWorkbook 'VBA搭載ファイル格納

Dim i As Long '転記元項番カウント
Dim j As Long '転記先項番カウント
Dim k As Long '転記元作業者カウント
Dim l As Long '転記先作業者カウント
Dim m As Long '平均値の分母
Dim total As Double  '転記元合計
Dim hantei As Double '判定
total = 0
hantei = 0

For k = 22 To 33
    For l = 5 To 16
      For i = 7 To 64
        For j = 7 To 15
            m = m + 1
            If Cells(i, 2) = Cells(j, 19) Then '転記元と転記先の項番照合
                If Cells(i, k) = "A" Then
                    hantei = 2
                ElseIf Cells(i, k) = "B" Then
                    hantei = 1
                ElseIf Cells(i, k) = "C" Then
                    hantei = 0.5
                ElseIf Cells(i, k) = "" Then
                    hantei = 0
                End If
                total = hantei + total
                total = total / m
                If total >= 2 Then
                    Cells(j, l) = "A"
                ElseIf total < 2 And total >= 1 Then
                   Cells(j, l) = "B"
                ElseIf total < 1 And total >= 0.5 Then
                   Cells(j, l) = "C"
                ElseIf total < 0.5 And total >= 0 Then
                  Cells(j, l) = ""
                End If
            End If
            Next j
            total = 0
            hantei = 0
        Next i
    Next l
Next k

Comments

[logres_Fan]

Excelの事はよく知りませんが、A、B、Cじゃなくて、2、1、0.5を入力するようにしないの？表計算汎用ソフトなのにね。数値に応じて表示を変える方法を検討したほうが。

[tatsu99]

転記先B列のNoと転記元S列のNo同士で、紐づけているように見えますが、
調整1,調整2,調整3は全てNo=8になっています。
これは、意図的なものでしょうか。もしそうであれば、NO同士で紐づけができないので、
転記先D列の内容と転記元T列の内容同士で、紐づけるようになります。

調整1,調整2,調整3はNo=8,9,10の間違いではないでしょうか。

[jabe]

logres_Fanさん
コメントありがとうございます。
確かにそうですね、ただ今回はA→数値→Aのように文字で対応したいと考えております。

tatsu99さん
コメントありがとうございます。
仰る通り、誤りでした。
正しくは、転記先：No.8検査と転記元：No.8調整1、調整2、調整3になります。

[logres_Fan]

> ただ今回はA→数値→Aのように文字で対応したいと考えております。
その場合も、数式とオートフィルで実現出来ないのでしょうか？

[jabe]

返信ありがとうございます。
その場合、別シートをもうけないとできないですかね？

[logres_Fan]

同じシートに、例えば、転記元(文字)→中間表(数値)→小計表(数値)→平均表(数値)→転記先では駄目でしょうか。参照セルを指定して変換・合計・平均など式を入れてオートフィル。問題が無ければ、数式を纏めて表を減らす感じで。

[jabe]

返信ありがとうございます。
試してみます。

Answer 1

・変数iのループと変数jのループはiのループが内側ではないでしょうか。
・m= m +1の行は転記元と転記先の項番照合のif文の内側へ
・分母で割る処理以降はiループの外側へ

    For j = 7 To 15
    
        For i = 7 To 64
            If Cells(i, 2) = Cells(j, 19) Then '転記元と転記先の項番照合
                '合計値計算、mカウント
            End If
        Next i

        '分母で割る処理、結果出力      
        Total = Total / m
        If Total >= 2 Then
            Cells(j, l) = "A"
        ElseIf Total < 2 And Total >= 1 Then
           Cells(j, l) = "B"
        ElseIf Total < 1 And Total >= 0.5 Then
           Cells(j, l) = "C"
        ElseIf Total < 0.5 And Total >= 0 Then
          Cells(j, l) = ""
        End If

        '変数初期化        
        m = 0
        Total = 0
        hantei = 0
    Next j

・kとlは個別にループするのではなく1例としてはこんな感じで

Dim k As Long '転記元Column
Dim l As Long '転記先Column

Dim 列オフセット As Long
Dim 作業者人数 As Long
    作業者人数 = 12

For 列オフセット = 1 To 作業者人数
   k = Cells(7, "V").Column + (列オフセット - 1)
   l = Cells(7, "E").Column + (列オフセット - 1)

Next

・処理速度に関しては配列を使っての一括書き込みを使わないのであればあまり変わらないかも。
以下の画面描画処理スキップで多少改善するかもしれません。

Application.ScreenUpdating = False
'処理
Application.ScreenUpdating = True

Comments

[jabe]

連絡と参考コードありがとうございます。
参考にさせていただきます。

Answer 2

以下のようにしてください。

Option Explicit

Dim ws As Worksheet     '作業シート
Public Sub 作業者能力計算()
    Dim manNo As Long       '作業者番号（左から1,2,3...）
    Set ws = ActiveSheet
    '転記先クリア
    ws.Range("E7:P19").ClearContents
    '全員分繰り返す
    For manNo = 1 To 12
        Call keisan(manNo)
    Next
    MsgBox ("完了")
End Sub

Private Sub keisan(ByVal manNo As Long)
    Const MAXWORK As Long = 13  '最大作業数
    Dim count(MAXWORK) As Long     '件数
    Dim point(MAXWORK) As Variant  '得点
    Dim wrow As Long    '作業行番号
    Dim trgcol As Long  '転記先列
    Dim srccol As Long  '転記元列
    Dim i As Long
    Dim rank As String  'ランク
    Dim wkno As Long    '作業番号
    Dim wp As Variant   '得点
    '集計テーブルクリア
    For i = 1 To MAXWORK
        count(i) = 0
        point(i) = 0
    Next
    trgcol = 4 + manNo
    srccol = 21 + manNo
    '作業NOを全行分行う
    For wrow = 7 To 64
        '作業NO取得
        wkno = ws.Cells(wrow, "S").Value
        If wkno < 1 Or wkno > MAXWORK Then
            MsgBox ("NO不正")
            ws.Activate
            ws.Cells(wrow, "S").Select
            End
        End If
        'ランク取得
        rank = ws.Cells(wrow, srccol).Value
        wp = -1
        If rank = "A" Then wp = 2
        If rank = "B" Then wp = 1
        If rank = "C" Then wp = 0.5
        If rank = "" Then wp = 0
        If wp = -1 Then
            MsgBox ("ランク不正")
            ws.Activate
            ws.Cells(wrow, srccol).Select
            End
        End If
        '集計テーブルへ加算
        count(wkno) = count(wkno) + 1
        point(wkno) = point(wkno) + wp
    Next
    '転記先へ出力
    For wkno = 1 To MAXWORK
        If count(wkno) <> 0 Then
            wp = point(wkno) / count(wkno)
            If wp >= 2 Then
                rank = "A"
            ElseIf wp >= 1 Then
                rank = "B"
            ElseIf wp >= 0.5 Then
                rank = "C"
            Else
                rank = ""
            End If
            ws.Cells(wkno + 6, trgcol).Value = rank
        End If
    Next
End Sub

Comments

[jabe]

ご丁寧にコード教えていただきありがとうございます。
試したところ、私の要望通り正確かつスピーディに動作しました。
凄いです。
一行ずつ理解できるように読み解いていきます。また引続きよろしくお願いします。