Q&A
Excelの事はよく知りませんが、A、B、Cじゃなくて、2、1、0.5を入力するようにしないの？表計算汎用ソフトなのにね。数値に応じて表示を変える方法を検討したほうが。
実現したいこと
転記元表から転記先表へ以下条件をもとに計算し記入する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の組み合わせ数が多いため、私のやり方だと処理に時間がかかると考えた為、処理スピードもあげる方法も教えていただきたいです。
該当のソースコード
VBA
1Sub 作業者能力計算() 2Dim TF As Workbook 'VBA搭載ファイル宣言 3Set TF = ThisWorkbook 'VBA搭載ファイル格納 4 5Dim i As Long '転記元項番カウント 6Dim j As Long '転記先項番カウント 7Dim k As Long '転記元作業者カウント 8Dim l As Long '転記先作業者カウント 9Dim m As Long '平均値の分母 10Dim total As Double '転記元合計 11Dim hantei As Double '判定 12total = 0 13hantei = 0 14 15For k = 22 To 33 16 For l = 5 To 16 17 For i = 7 To 64 18 For j = 7 To 15 19 m = m + 1 20 If Cells(i, 2) = Cells(j, 19) Then '転記元と転記先の項番照合 21 If Cells(i, k) = "A" Then 22 hantei = 2 23 ElseIf Cells(i, k) = "B" Then 24 hantei = 1 25 ElseIf Cells(i, k) = "C" Then 26 hantei = 0.5 27 ElseIf Cells(i, k) = "" Then 28 hantei = 0 29 End If 30 total = hantei + total 31 total = total / m 32 If total >= 2 Then 33 Cells(j, l) = "A" 34 ElseIf total < 2 And total >= 1 Then 35 Cells(j, l) = "B" 36 ElseIf total < 1 And total >= 0.5 Then 37 Cells(j, l) = "C" 38 ElseIf total < 0.5 And total >= 0 Then 39 Cells(j, l) = "" 40 End If 41 End If 42 Next j 43 total = 0 44 hantei = 0 45 Next i 46 Next l 47Next k 48
転記先B列のNoと転記元S列のNo同士で、紐づけているように見えますが、
調整1,調整2,調整3は全てNo=8になっています。
これは、意図的なものでしょうか。もしそうであれば、NO同士で紐づけができないので、
転記先D列の内容と転記元T列の内容同士で、紐づけるようになります。
調整1,調整2,調整3はNo=8,9,10の間違いではないでしょうか。
logres_Fanさん
コメントありがとうございます。
確かにそうですね、ただ今回はA→数値→Aのように文字で対応したいと考えております。
tatsu99さん
コメントありがとうございます。
仰る通り、誤りでした。
正しくは、転記先：No.8検査と転記元：No.8調整1、調整2、調整3になります。
> ただ今回はA→数値→Aのように文字で対応したいと考えております。
その場合も、数式とオートフィルで実現出来ないのでしょうか？
返信ありがとうございます。
その場合、別シートをもうけないとできないですかね？
同じシートに、例えば、転記元(文字)→中間表(数値)→小計表(数値)→平均表(数値)→転記先では駄目でしょうか。参照セルを指定して変換・合計・平均など式を入れてオートフィル。問題が無ければ、数式を纏めて表を減らす感じで。
返信ありがとうございます。
試してみます。
回答2件
0
・変数iのループと変数jのループはiのループが内側ではないでしょうか。
・m= m +1の行は転記元と転記先の項番照合のif文の内側へ
・分母で割る処理以降はiループの外側へ
VBA
1 For j = 7 To 15 2 3 For i = 7 To 64 4 If Cells(i, 2) = Cells(j, 19) Then '転記元と転記先の項番照合 5 '合計値計算、mカウント 6 End If 7 Next i 8 9 '分母で割る処理、結果出力 10 Total = Total / m 11 If Total >= 2 Then 12 Cells(j, l) = "A" 13 ElseIf Total < 2 And Total >= 1 Then 14 Cells(j, l) = "B" 15 ElseIf Total < 1 And Total >= 0.5 Then 16 Cells(j, l) = "C" 17 ElseIf Total < 0.5 And Total >= 0 Then 18 Cells(j, l) = "" 19 End If 20 21 '変数初期化 22 m = 0 23 Total = 0 24 hantei = 0 25 Next j 26
・kとlは個別にループするのではなく1例としてはこんな感じで
VBA
1Dim k As Long '転記元Column 2Dim l As Long '転記先Column 3 4Dim 列オフセット As Long 5Dim 作業者人数 As Long 6 作業者人数 = 12 7 8For 列オフセット = 1 To 作業者人数 9 k = Cells(7, "V").Column + (列オフセット - 1) 10 l = Cells(7, "E").Column + (列オフセット - 1) 11 12Next
・処理速度に関しては配列を使っての一括書き込みを使わないのであればあまり変わらないかも。
以下の画面描画処理スキップで多少改善するかもしれません。
VBA
1Application.ScreenUpdating = False 2'処理 3Application.ScreenUpdating = True
投稿2023/03/28 17:03
編集2023/03/28 17:06
総合スコア89
0
ベストアンサー
以下のようにしてください。
VBA
1Option Explicit 2 3Dim ws As Worksheet '作業シート 4Public Sub 作業者能力計算() 5 Dim manNo As Long '作業者番号（左から1,2,3...） 6 Set ws = ActiveSheet 7 '転記先クリア 8 ws.Range("E7:P19").ClearContents 9 '全員分繰り返す 10 For manNo = 1 To 12 11 Call keisan(manNo) 12 Next 13 MsgBox ("完了") 14End Sub 15 16Private Sub keisan(ByVal manNo As Long) 17 Const MAXWORK As Long = 13 '最大作業数 18 Dim count(MAXWORK) As Long '件数 19 Dim point(MAXWORK) As Variant '得点 20 Dim wrow As Long '作業行番号 21 Dim trgcol As Long '転記先列 22 Dim srccol As Long '転記元列 23 Dim i As Long 24 Dim rank As String 'ランク 25 Dim wkno As Long '作業番号 26 Dim wp As Variant '得点 27 '集計テーブルクリア 28 For i = 1 To MAXWORK 29 count(i) = 0 30 point(i) = 0 31 Next 32 trgcol = 4 + manNo 33 srccol = 21 + manNo 34 '作業NOを全行分行う 35 For wrow = 7 To 64 36 '作業NO取得 37 wkno = ws.Cells(wrow, "S").Value 38 If wkno < 1 Or wkno > MAXWORK Then 39 MsgBox ("NO不正") 40 ws.Activate 41 ws.Cells(wrow, "S").Select 42 End 43 End If 44 'ランク取得 45 rank = ws.Cells(wrow, srccol).Value 46 wp = -1 47 If rank = "A" Then wp = 2 48 If rank = "B" Then wp = 1 49 If rank = "C" Then wp = 0.5 50 If rank = "" Then wp = 0 51 If wp = -1 Then 52 MsgBox ("ランク不正") 53 ws.Activate 54 ws.Cells(wrow, srccol).Select 55 End 56 End If 57 '集計テーブルへ加算 58 count(wkno) = count(wkno) + 1 59 point(wkno) = point(wkno) + wp 60 Next 61 '転記先へ出力 62 For wkno = 1 To MAXWORK 63 If count(wkno) <> 0 Then 64 wp = point(wkno) / count(wkno) 65 If wp >= 2 Then 66 rank = "A" 67 ElseIf wp >= 1 Then 68 rank = "B" 69 ElseIf wp >= 0.5 Then 70 rank = "C" 71 Else 72 rank = "" 73 End If 74 ws.Cells(wkno + 6, trgcol).Value = rank 75 End If 76 Next 77End Sub 78 79
投稿2023/03/29 05:29
総合スコア5540
ご丁寧にコード教えていただきありがとうございます。
試したところ、私の要望通り正確かつスピーディに動作しました。
凄いです。
一行ずつ理解できるように読み解いていきます。また引続きよろしくお願いします。
あなたの回答
tips
プレビュー
