[[20231110142656]]　『指定した年月の営業実績件数を降順に出力できるよ』（初心者その1）　ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

　

『指定した年月の営業実績件数を降順に出力できるようなランキング機能。 』（初心者その1）

https://f.yourl.jp/7434797e
こちらの表を↓完成形のイメージ
https://f.yourl.jp/9a3512f2/
このようにしたいのですが（これは手作業）
（2）Do until文で
　　　営業開始日から８ヶ月未満部門と８ヶ月以上部門で順位を別々に出力する。
（3）必要に応じて、機能変更を行わない範囲で、既存シートに行、列を追加、
　　 または書式設定等を変更することは可とする。
（4）ソート処理において、SORT関数、RANK関数は使用しないこと。

     ※「バブルソート」アルゴリズムを使って実現すること						
（5）件数に応じて、人数ベースで順位を表示すること。						
     例）同順位が複数人存在する場合						
         １位　Aさん						
         ２位　Bさん						
         ２位　Cさん						
         ４位　Dさん						
(2)からのコードがうまいこといってくれません。こういう答えもあるとかアドバイスいただけたらお願いします。20時間以上詰まってます。
コードはこちら。
Sub 実行ボタン_Click()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim year As Integer
    Dim month As Integer
    Dim i As Integer
    Dim errorMsg As String
    Dim targetRow As Integer
    Dim targetCol As Integer
    Dim j As Integer
    Dim Row As Integer
    Dim Col As Integer

    ' シートを指定
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("営業実績（稼働件数推移）")

    ' 年と月をB2とD2から取得
    year = ws1.Range("B2").Value
    month = ws1.Range("D2").Value

    ' 年と月が変更された場合、シート1のデータをクリア
    ws1.Range("B11:AD11").Clear

    ' 年の判定
    If year & "年" <> "2019年" And year & "年" <> "2020年" Then
        errorMsg = "年は2019年か2020年を入力してください。"
    End If

    ' 月の判定
    If month < 1 Or month > 12 Then
        errorMsg = "月は1から12の範囲で入力してください。"
    End If

    ' データを出力
    i = 9
    Row = 5
    targetRow = 10
    targetCol = 16

    MsgBox ws2.Cells(3, i).Value
    MsgBox ws2.Cells(4, i).Value

    ' 対応する年の列が見つかるまでループ 別ものとして考える
    Do Until i > 29
        If ws2.Cells(3, i).Value = year & "年" And ws2.Cells(4, i).Value = month & "月" Then ' 会社名を転記
            '
            j = 5
          End If
        i = i + 1 ' 次の列に進む

    Loop

    ' targetRowとtargetColの値をデバッグ表示
    MsgBox "targetRow: " & targetRow
    MsgBox "targetCol: " & targetCol

    ' 対応する年月が見つからなかった場合
    If i > 29 Then
        errorMsg = "指定した年月のデータが見つかりません。"
    End If

    ' エラーメッセージが設定されている場合は表示
    If Len(errorMsg) > 0 Then
        MsgBox errorMsg, vbExclamation
    End If
End Sub
途中までのコードです。
まずは→側に指定した年月の、会社名、氏名、件数の数字がある人を転記したくて
次に8ヶ月未満※ある人ない人、の判定
最後に降順バブルソートで順位繰り上げ表示で完了です。

＜ 使用 Excel：Excel2019、使用 OS：Windows10 ＞

---

Sub 実行ボタン_Click()

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim year As Integer
    Dim month As Integer
    Dim i As Integer
    Dim errorMsg As String
    Dim targetRow As Integer
    Dim targetCol As Integer
    Dim j As Integer
    Dim Row As Integer

    ' シートを指定
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("営業実績（稼働件数推移）")

    ' 年と月をB2とD2から取得
    year = ws1.Range("B2").Value
    month = ws1.Range("D2").Value

    ' 年と月が変更された場合、シート1のデータをクリア
    ws1.Range("B11:AD11").Clear

    ' 年の判定
    If year & "年" <> "2019年" And year & "年" <> "2020年" Then
        errorMsg = "年は2019年か2020年を入力してください。"
    End If

    ' 月の判定
    If month < 1 Or month > 12 Then
        errorMsg = "月は1から12の範囲で入力してください。"
    End If

    ' データを出力
    i = 9
    Row = 5
    targetRow = 10
    targetCol = 16

    ' 対応する年の列が見つかるまでループ
    Do Until i > 29
        If ws2.Cells(3, i).Value = year & "年" And ws2.Cells(4, i).Value = month & "月" Then

            ' 会社名を転記
            ' 漢字氏名
            ' 件数
            j = 5
            Do Until j > 43
                ws1.Cells(targetRow, targetCol).Value = ws2.Cells(j, 3).Value
                ws1.Cells(targetRow, targetCol + 1).Value = ws2.Cells(j, 3 + 1).Value
                ws1.Cells(targetRow, targetCol + 2).Value = ws2.Cells(j, i + 2).Value

                ' 次のセットに進む
                targetRow = targetRow + 1
                j = j + 1
            Loop

            Exit Do
        End If
        i = i + 1 ' 次の列に進む
    Loop

    ' targetRowとtargetColの値をデバッグ表示
    MsgBox "targetRow: " & targetRow
    MsgBox "targetCol: " & targetCol

    ' 対応する年月が見つからなかった場合
    If i > 29 Then
        errorMsg = "指定した年月のデータが見つかりません。"
    End If

    ' エラーメッセージが設定されている場合は表示
    If Len(errorMsg) > 0 Then
        MsgBox errorMsg, vbExclamation
    End If
End Sub
現在このコードで2019年4月の件数データは引っ張ることに成功しましたが。

 ws1.Cells(targetRow, targetCol).Value = ws2.Cells(j, 3).Value
                ws1.Cells(targetRow, targetCol + 1).Value = ws2.Cells(j, 3 + 1).Value
                ws1.Cells(targetRow, targetCol + 2).Value = ws2.Cells(j, i + 2).Value
ここの部分の複数の指定セルに別シートに転記をしたいです。
ws2.Cells(j, i)にして正常に動かせる文が思いつかない状態です。

（初心者その1） 2023/11/10(金) 16:41:18

---

 ＞現在このコードで2019年4月の件数データは引っ張ることに成功しましたが。
 If ws2.Cells(3, i).Value = year & "年" And ws2.Cells(4, i).Value = month & "月" Then 
 結合セルは結合範囲の最初のセルに値を持っているので、
 2019年5月の列に移動してしまうと、ws2.Cells(3, i).Value は空になるので、年月の取得が出来ていません。
 2019年4月の場合は、結合セルの最初なので「2019年」を取得しているので成功したということです。

 Dim 年 As String と宣言して、ループの最初に
 If ws2.Cells(3, i) <> "" Then 年 = ws2.Cells(3, i)
 としてから、
 If 年 = year & "年" And ws2.Cells(4, i).Value = month & "月" Then
 としてみてください。

 コードが思う様に動作していないと思ったら、デバッグすることをオススメします。
 デバッグのひとつとして、ステップ実行があります。
 コードを１行ずつ実行して確認する方法です。
 今回のケースだとws2.Cells(3, i).Valueを確認しながら動かせば、空だったことがわかったと思います。
 以下、参考です。この他にもありますので「VBA デバッグ 方法」等でWeb検索して自分にあった記事を探して下さい。
https://excel-ubara.com/excelvba1/EXCELVBA490.html

 外部サイトへのリンクは敬遠されるケースが多いので、
[[20110209184943]][談]シートレイアウトの投稿どうしてますか？』（ｍｏｍｏ）
 にあるようなコードを用いて、テキストとして投稿されると返答が付きやすいと思います。
（外野フライ） 2023/11/11(土) 08:56:57

---

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

（初心者その1） 2023/11/12(日) 13:33:36

---

Sub 実行ボタン_Click()

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim year As Integer
    Dim month As Integer
    Dim i As Integer
    Dim errorMsg As String
    Dim targetRow As Integer
    Dim targetCol As Integer
    Dim j As Integer
    Dim Row As Integer
    Dim foundColumn As Integer
    Dim 年 As String
    Dim 月 As String

    ' シートを指定
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("営業実績（稼働件数推移）")

    ' 年と月をB2とD2から取得
    year = ws1.Range("B2").Value
    month = ws1.Range("D2").Value

    ' 年と月が変更された場合、シート1のデータをクリア
    ws1.Range("B11:AD11").Clear

    ' 年の判定
    If year & "年" <> "2019年" And year & "年" <> "2020年" Then
        errorMsg = "年は2019年か2020年を入力してください。"
    End If

    ' 月の判定
    If month < 1 Or month > 12 Then
        errorMsg = "月は1から12の範囲で入力してください。"
    End If

    ' 対応する年の列が見つかるまでループ
    foundColumn = 0
    i = 9
    Do Until i > 29
       If 年 = year & "年" And ws2.Cells(4, i).Value = month & "月" Then
            foundColumn = i
            Exit Do
        End If
        i = i + 1 ' 次の列に進む
    Loop

    ' 対応する年月が見つからなかった場合
    If foundColumn = 0 Then
        errorMsg = "指定した年月のデータが見つかりません。"
    Else
        ' 会社名、漢字氏名、件数の転記
        targetRow = 10
        targetCol = 16
        j = 5
        Do Until j > 43
            ws1.Cells(targetRow, targetCol).Value = ws2.Cells(j, i).Value
            ws1.Cells(targetRow, targetCol + 1).Value = ws2.Cells(j, i + 1).Value
            ws1.Cells(targetRow, targetCol + 2).Value = ws2.Cells(j, foundColumn).Value

            ' 次のセットに進む
            targetRow = targetRow + 1
            j = j + 1
        Loop
    End If

    ' targetRowとtargetColの値をデバッグ表示
    MsgBox "targetRow: " & targetRow
    MsgBox "targetCol: " & targetCol

    ' エラーメッセージが設定されている場合は表示
    If Len(errorMsg) > 0 Then
        MsgBox errorMsg, vbExclamation
    End If
End Sub
すみません。アドバイスしてくれた箇所を修正したところ年月データは見つかりませんとでます。
アドバイスあればよろしくお願いします。

（初心者その1） 2023/11/13(月) 10:17:36

---

Sub 実行ボタン_Click()

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim year As Integer
    Dim month As Integer
    Dim i As Integer
    Dim errorMsg As String
    Dim targetRow As Integer
    Dim targetCol As Integer
    Dim j As Integer
    Dim Row As Integer
    Dim foundColumn As Integer
    Dim 年 As String
    Dim 月 As String

    ' シートを指定
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("営業実績（稼働件数推移）")

    ' 年と月をB2とD2から取得
    year = ws1.Range("B2").Value
    month = ws1.Range("D2").Value

    ' 年と月が変更された場合、シート1のデータをクリア
    ws1.Range("B11:AD11").Clear

    ' 年の判定
    If year & "年" <> "2019年" And year & "年" <> "2020年" Then
        errorMsg = "年は2019年か2020年を入力してください。"
    End If

    ' 月の判定
    If month < 1 Or month > 12 Then
        errorMsg = "月は1から12の範囲で入力してください。"
    End If

    ' 対応する年の列が見つかるまでループ
    foundColumn = 0
    i = 9
    Do Until i > 29
      If ws2.Cells(3, i) <> "" Then 年 = ws2.Cells(3, i)
         If 年 = year & "年" And ws2.Cells(4, i).Value = month & "月" Then
            foundColumn = i
            Exit Do
        End If
        i = i + 1 ' 次の列に進む
    Loop

    ' 対応する年月が見つからなかった場合
    If foundColumn = 0 Then
        errorMsg = "指定した年月のデータが見つかりません。"
    Else
        ' 会社名、漢字氏名、件数の転記
        targetRow = 10
        targetCol = 14
        j = 5
        Do Until j > 43
            ws1.Cells(targetRow, targetCol).Value = ws2.Cells(j, 3).Value
            ws1.Cells(targetRow, targetCol + 1).Value = ws2.Cells(j, 4).Value
            ws1.Cells(targetRow, targetCol + 2).Value = ws2.Cells(j, foundColumn).Value

            ' 次のセットに進む
            targetRow = targetRow + 1
            j = j + 1
        Loop
    End If

    ' targetRowとtargetColの値をデバッグ表示
    MsgBox "targetRow: " & targetRow
    MsgBox "targetCol: " & targetCol

    ' エラーメッセージが設定されている場合は表示
    If Len(errorMsg) > 0 Then
        MsgBox errorMsg, vbExclamation
    End If
End Sub
すみません。
ちゃんと修正しましたら正常に動きました。
ありがとうございます。
次は新人とベテランに分けるためにフラグ管理について頑張ります。
（初心者その1） 2023/11/13(月) 10:33:48

---

Sub 実行ボタン_Click()

    ' 変数の宣言
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim year As Integer
    Dim month As Integer
    Dim i As Integer
    Dim errorMsg As String
    Dim targetRow As Integer
    Dim targetCol As Integer
    Dim j As Integer
    Dim Row As Integer
    Dim foundColumn As Integer
    Dim 年 As String
    Dim 月 As String

    ' シートを指定
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("営業実績（稼働件数推移）")

    ' 年と月をB2とD2から取得
    year = ws1.Range("B2").Value
    month = ws1.Range("D2").Value

    ' 年と月が変更された場合、シート1のデータをクリア
    ws1.Range("B11:AD11").Clear

    ' 年の判定
    If year & "年" <> "2019年" And year & "年" <> "2020年" Then
        errorMsg = "年は2019年か2020年を入力してください。"
    End If

    ' 月の判定
    If month < 1 Or month > 12 Then
        errorMsg = "月は1から12の範囲で入力してください。"
    End If

    ' 対応する年の列が見つかるまでループ
    foundColumn = 0
    i = 9
    Do Until i > 29
        If ws2.Cells(3, i) <> "" Then 年 = ws2.Cells(3, i)
        If 年 = year & "年" And ws2.Cells(4, i).Value = month & "月" Then
            foundColumn = i
            Exit Do
        End If
        i = i + 1 ' 次の列に進む
    Loop

    ' 対応する年月が見つからなかった場合
    If foundColumn = 0 Then
        errorMsg = "指定した年月のデータが見つかりません。"
    Else
        ' 会社名、漢字氏名、件数の転記
        targetRow = 11

        ' ※が含まれているかどうかの判定を行いながら、指定した年月の行を1つずつずらしていく
        j = 5
        Do Until j > 43
            If InStr(ws2.Cells(j, 8).Value, "※") > 0 Then
                ' ※が含まれている場合はws1.Cells(targetRow, 2)から転記
                targetCol = 2
            Else
                ' ※が含まれていない場合はws1.Cells(targetRow, 8)から転記
                targetCol = 8
            End If

            ' 会社名、漢字氏名、件数の転記
            ws1.Cells(targetRow, targetCol).Value = ws2.Cells(j, 3).Value
            ws1.Cells(targetRow, targetCol + 1).Value = ws2.Cells(j, 4).Value
            ws1.Cells(targetRow, targetCol + 2).Value = ws2.Cells(j, foundColumn).Value

            ' 次のセットに進む
            targetRow = targetRow + 1
            j = j + 1
        Loop
    End If

    ' エラーメッセージが設定されている場合は表示
    If Len(errorMsg) > 0 Then
        MsgBox errorMsg, vbExclamation
    End If
End Sub
現在新人とベテランにわけて転記するという所まで来ましたが
このコードですと飛び飛びに転記してしまい、行を詰めながら順番に転記するという処理はどう書けばいいでしょうか？

（初心者その1） 2023/11/13(月) 14:42:45

---

 全然きちんと見ていないので的外れならスミマセン。
 ・転記先の行管理用の変数を別途作る
 ・新人は新人、ベテランはベテランで配列にぶち込んでから転記
 とかでどうでしょ？
（i） 2023/11/13(月) 17:49:03

---

 既にご指摘ありますが、

    If ※が含まれている場合 Then
        新人行 = 新人行 + 1
        ws1.Cells(新人行, 2)・・・・
    Else
        ベテラン行 = ベテラン行 + 1
        ws1.Cells(ベテラン行, 8)・・・
    End If

 みたいにするか、
 別の方法だと、まず、ws1.Range("B11:AD11").Clear この箇所を見直して、
 見出し行より下は全てクリアするようにしてから、
 都度最下行を求めて、その直下に書き込むようにするとか。 

    With ws1.Cells(Rows.Count, targetCol).End(xlUp).Offset(1)
        .Resize(, 2).Value = ws2.Cells(j, 3).Resize(, 2).Value
        .Offset(, 2).Value = ws2.Cells(j, foundColumn).Value
    End With
（外野フライ） 2023/11/13(月) 20:08:44

---

お二方、アドバイスありがとうございます！
助かりました！
またわからなくなったら教えてください！
（初心者その1） 2023/11/14(火) 20:29:41

---

コメント返信：

---

[ 一覧(最新更新順) ]

---

YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.