質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

90.52%

  • VBA

    1790questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

ExcelVBAについて急ぎです。どなたか教えてください。

受付中

回答 2

投稿

  • 評価
  • クリップ 0
  • VIEW 938

jfem

score 2

前提・実現したいこと

ExcelVBAについてです。ある列に、昇順に文字列が並んでいます。昇順ではありますが、条件分岐させる際、同じとみなされる文字列(01××、01○○、01△△等)が続けて並んでいます。条件に見合うものがあればその行のいくつかのセルを抜き出します。一つ条件に見合う文字列が見つかれば、以降はその条件に見合う文字列が見つかっても、スルーします。また、昇順に文字列が並んでいても、抜け落ちている部分(01××、02××、03××ではなく、01××、03××のように)があります。その場合抜け落ちている部分を直前に抜き出した文字列の後に、続けて連番にしていきます。続け方は抜け落ちている部分(先程の例でいえば、02××)と直前に抜き出したものと同じものです。図で示すと以下のようになります。

実行前のシート 実行後の(別)シート
A B C A B C
1 01×× 1234 1236  1 01 1234 1236
2 01○○ 2513 3652 2 02 1234 1236
3 03■■ 8564 9641 ⇒ 3 03 8564 9641
4 05□□ 2289 3654 4 04 8564 9641
5 05○□ 3568 4875 5 05 2289 3654
・ ・ ・ ・ ・ ・ ・ ・
スルーする部分まで以下のようにコードを書きましたが、欠番の部分をどう書いたらいいかわからず進んでおりません。まだ、実行まで進んでおりません。
どうかよろしくお願いいたします。

該当のソースコード

Dim i As Long
Dim j=2 As Long
For i=2 To .Cells(Rows.Count,1).End(xlUp).Row 
If .Cells(i,1) == .Cells(i+1,1) Then
.Sheet(別シート).Cells(j,2)= Left(.Cells(i,1),2)
.Sheet(別シート).Cells(j,2)= .Cells(i,2)
.Sheet(別シート).Cells(j,2)= .Cells(i,3)
End If
i = i+1
Do While (.Cells(i,1) == .Cells(i+1,1))
i = i+1
Loop
Next

補足情報(言語/FW/ツール等のバージョンなど)

Excel2010 、win7

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 2

0

整列済みの連続番号セルをもとにした定番のグループトータルアルゴリズムを使えばできます。
同一番号かを見張る変数gflagと欠番を埋めるためのhozoncell変数を用意し、番号がgflagと違ったときに新しい値をうつすか、欠番を埋めるかの処理を行います。そして、番号が一致しているときは、単純に次のセルにうつるように変数iに1を足します。
未検証ですが、以下のようなコードの形になると思います。

 Dim i As Long 
 Dim j=2 As Long

' 引き継ぎたいB列、C列のセルの値を保存する変数
 Dim hozoncell2, hozoncell As Variant

' グループがかわったを見張る見張りフラグ(欠番判断も兼ねる)
 Dim gflag=0 As Long

 i = 2
 Do While i <= .Cells(Rows.Count,1).End(xlUp).Row  
   If .Cells(i,1) > gflag Then
' 単純に次の順番のデータの転送
     If .Cells(i,1) == gflag + 1 Then
       .Sheet(別シート).Cells(j,2)= Left(.Cells(i,1),2) 
       .Sheet(別シート).Cells(j,2)= .Cells(i,2) 
       .Sheet(別シート).Cells(j,3)= .Cells(i,3) 
' 見張りフラグを書き換えて、旧データを保存しておく
       gflag = .Cells(i,1)
       hozoncell2 = .Cells(i,2)
       hozoncell3 = .Cells(i,3)
'   アクティブシートの行ポインタ i の移動
       i = i+1 
'   別シートの行ポインタ j の移動
       j = j+1
     Else
' 欠番があったときに旧データを転送していく
       Do While .Cells(i,1) < gflag + 1
         gflag = gflag + 1
         .Sheet(別シート).Cells(j,2)= gflag
         .Sheet(別シート).Cells(j,2)= hozoncell2
         .Sheet(別シート).Cells(j,3)= hozoncell3
         j = j+1
       Loop 
     End If
   Else
' 同一番号の時は何もせずにアクティブシートのポインタを次の行にうつす。
     i = i+1 
   End If
 Loop


校正した際に19行目に入れていた i=i+1 が間違いと気づいたので、下側に移しました。

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2017/02/07 09:16

    早速のご回答ありがとうございます。助かりました。現在検証しております。

    キャンセル

0

今回の処理を行う場合、以下が前提になると思いますが認識あってますでしょうか?
・実行前シートのA列先頭2桁をキーとして判定をする
・欠番が判定できることから、キー2桁は最低が「00」、最大が「99」である

あと欠番の自動作成の部分について、
・実行後シートには実行前シートの先頭キー番号~最終キー番号(例では「01」~「05」の5行)のデータが作成される。
⇒前行のデータから自動作成するのは番号が飛んだ時だけで、最終データ以降の欠番は作成しない
という認識ですがあってますでしょうか?


以上を前提として改修方針を説明します。

全体の流れは

①キー退避変数の作成・初期化を行う
②実行前シートのデータ行をループ処理

 (行ループここから)
 
 ③処理行のA列セルからキー値(先頭2桁)を取得
 
 ④キー値の判定
  ④-a キー値が退避変数と同じ場合
    ⇒ ④-a-1 次の行へスキップ

  ④-b キー値が退避変数+1の場合
    ⇒ ④-b-1 今回行の内容を実行後シートに出力
      ④-b-1 退避変数に今回のキー値をセット

  ④-c キー値が退避変数+1でない場合
    ⇒ ④-c-1 退避変数+1からキー値-1まで欠番を補うループ処理
      (欠番ループここから)
          ④-c-2 前行の内容で実行後シートに出力
      (欠番ループここまで)
      ④-c-3 今回行の内容を実行後シートに出力
      ④-c-4 退避変数に今回のキー値をセット
  
 (行ループここまで)
⑤処理終了


条件分岐があって少しわかりずらいですが、こんな流れになると思います。

これをコードに落とすと以下のようになります。

Sub test()
    Dim iKey As Integer     '今回のキー値
    Dim iKey_Bk As Integer  '前回のキー値
    iKey_Bk = -1    '初期化

    Dim iRowR As Long '読込行
    Dim iRowW As Long '出力行
    Dim iLoop As Long '欠番ループカウンタ
    iRowW = 2

    With Sheets("元シート")
        For iRowR = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
            'キー値を取得
            iKey = CInt(Left(.Cells(iRowR, 1), 2))

            If iKey = iKey_Bk Then
                '前回と同じキーなら処理しない
            ElseIf iKey_Bk = -1 Or (iKey = iKey_Bk + 1) Then
                '初回、もしくは前回キー+1の場合はコピー処理
                Sheets("別シート").Cells(iRowW, 1) = Format(iKey, "00")
                Sheets("別シート").Cells(iRowW, 2) = .Cells(iRowR, 2)
                Sheets("別シート").Cells(iRowW, 3) = .Cells(iRowR, 3)
                '出力行を進める
                iRowW = iRowW + 1
                'キーを退避
                iKey_Bk = iKey
            Else
                '前回キー+1でない場合は欠番作成
                For iLoop = iKey_Bk + 1 To iKey - 1
                    '前行と同じ値でコピー処理
                    iKey_Bk = iKey_Bk + 1
                    Sheets("別シート").Cells(iRowW, 1) = Format(iKey_Bk, "00")
                    Sheets("別シート").Cells(iRowW, 2) = Sheets("別シート").Cells(iRowW - 1, 2)
                    Sheets("別シート").Cells(iRowW, 3) = Sheets("別シート").Cells(iRowW - 1, 3)
                    '出力行を進める
                    iRowW = iRowW + 1
                Next iLoop
                '今回キーのコピー処理
                Sheets("別シート").Cells(iRowW, 1) = Format(iKey, "00")
                Sheets("別シート").Cells(iRowW, 2) = .Cells(iRowR, 2)
                Sheets("別シート").Cells(iRowW, 3) = .Cells(iRowR, 3)
                '出力行を進める
                iRowW = iRowW + 1
                'キーを退避
                iKey_Bk = iKey
            End If
        Next
    End With
End Sub

今回は元シートの行数分ループして欠番を判定しましたが、
①先頭キー番号と最終キー番号をあらかじめ取得する
②先頭キー番号~最終キー番号までをループする
③処理中のキー番号(先頭行)を元シートから検索し、見つけた行からコピーする
という方法でも実現できると思います。

この場合、出力する行数分しかループしないのでループ回数は減りますが、検索する分処理が重くなりそうです(^-^;
ここで伝えたかったのは、実装方法は一つではないので用途に応じて使い分けましょう、ということです。

参考になれば幸いです。

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 90.52%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る

  • VBA

    1790questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。