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

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

ただいまの
回答率

90.13%

エクセルVBA指定文字数を抽出したい

解決済

回答 3

投稿

  • 評価
  • クリップ 0
  • VIEW 1,899

cd987456

score 31

エクセルファイルに”抽出結果”というシートがあり、"着手予定日"という列があります。
セルには9桁の数字が入っています。
1桁目~8桁目までで西暦4桁+月2桁+日2桁を表しています。9桁目は1が入っています。
やりたい事は9桁目の1を一括で消したいです。できるだけ高速処理したいです。

対象数は毎回違うのですが、最大90万くらいです。
FOR~NEXT で処理すると私のパソコンで40万で6秒くらいです。
コードを以下に書きました。

★例えば、配列に格納し、格納したデータから指定文字数を抽出などできますか?
FOR~NEXTより早くできる処理を御存知の方、教えて下さい。

Sub 末番削除()

Dim CNT As Long, I As Long, COL As Long
Dim maxrow As Long
Dim MAXCOL As Long

    With Sheets("抽出結果").Range("A1").SpecialCells(xlLastCell)
        maxrow = .Row
        MAXCOL = .Column
    End With

    With Sheets("抽出結果")
        CNT = WorksheetFunction.CountIf(.Range(.Cells(2, 1), .Cells(2, MAXCOL)), "着手予定日")
        If CNT > 0 Then
            COL = .Rows(2).Find("着手予定日").Column

            For I = 4 To maxrow
                .Cells(I, COL).Value = Mid(.Cells(I, COL), 1, 8)
            Next I
        Else: End If
    End With

End Sub


※"着手予定日"の列番を探しているのは"抽出結果"シートには色々なデータが表示できるように
してある為、ない場合もあるからです。

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

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

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

    クリップを取り消します

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

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

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

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

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

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

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

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

    質問の評価を下げる

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

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

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

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

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

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

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

    詳細な説明はこちら

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

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

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

回答 3

checkベストアンサー

+4

配列に格納して、配列で9桁→8桁変換してから、もとのレンジに戻す。
試してないけど、どのくらい改善できるかな。
結果がでたら報告してほしいです。

Sub 末番削除_配列版()

Dim Row As Long, Col As Long
Dim maxrow As Long
Dim MAXCOL As Long
Dim ColumnNames()   '列名格納用配列
Dim ColumnValues()  '列のデータ格納用配列
Dim rng As Range

    Application.ScreenUpdating = False
    With Sheets("抽出結果")
        With .Range("A1").SpecialCells(xlLastCell)
            maxrow = .Row
            MAXCOL = .Column
        End With
        ColumnNames = .Range(.Cells(2, 1), .Cells(2, MAXCOL)).Value
        For Col = 1 To MAXCOL
            If ColumnNames(1, Col) = "着手予定日" Then
                Set rng = .Range(.Cells(4, Col), .Cells(maxrow, Col))
                ColumnValues = rng.Value
                For Row = 4 To maxrow
                    ColumnValues(Row - 3, 1) = Left(ColumnValues(Row - 3, 1), 8)
                Next
                rng.Value = ColumnValues
            End If
        Next
    End With
    Application.ScreenUpdating = True
End Sub

投稿

  • 回答の評価を上げる

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

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

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

  • 回答の評価を下げる

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

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

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

  • 2017/06/29 16:41

    hatenaさんの回答の直後に似たような回答を投稿してしまいましたが、こちらのほうが優秀です。

    私のコードと決定的に違うのが値のセットの仕方です。
    私のはセル範囲から値を取り出してその値をセルに戻していましたが、hatenaさんのはセル範囲の値をまとめて配列に格納し、その配列をループして処理した結果をセルに戻しているので、セルからの取り出し・書き出しが1回ずつで済んでいるというところです。

    ちなみに私のコードを計測したものと同じデータを使って計測したところ、3秒/40万件で処理が終わりました。
    (/^ー^)/"""パチパチ

    キャンセル

  • 2017/06/29 17:33

    hatena19さん
    回答ありがとうございます。劇的に早くなりました。私のパソコンで2秒くらいでした。
    配列恐るべしです。ありがとうございました。

    キャンセル

0

40万で6秒ですか。
随分速いPCですな。
私の環境でやったら30秒かかりましたよ。とほほ。
それはさておき、とりあえずですが、描画の更新をしないとだいぶ改善されると思うので、次のようにしてみてください。
私の環境では3倍ほど速くなりました。

Application.ScreenUpdating = False
For I = 4 To maxrow
    .Cells(I, COL).Value = Mid(.Cells(I, COL), 1, 8)
Next I
Application.ScreenUpdating = True

投稿

  • 回答の評価を上げる

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

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

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

  • 回答の評価を下げる

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

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

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

  • 2017/06/29 17:25

    ttyp03さん
    回答ありがとうございます。御指摘ありがとうございます。
    描画OFFしたら少し早くなりました。ありがとうございます。

    キャンセル

0

ttyp03さんのアドバイスにもありますが、処理速度の改善には画面描画OFFが基本です。

あと、セルの値を直接参照するよりも対象範囲を変数に格納して参照する方が早くなります。

Sub 末番削除2()

    Dim CNT As Long, I As Long, COL As Long
    Dim maxrow As Long
    Dim MAXCOL As Long

    Dim area As Range   '処理範囲

    Cells(1, 1) = Now

    '画面描画OFF
    Application.ScreenUpdating = False

    With Sheets("抽出結果").Range("A1").SpecialCells(xlLastCell)
        maxrow = .Row
        MAXCOL = .Column
    End With

    With Sheets("抽出結果")
        CNT = WorksheetFunction.CountIf(.Range(.Cells(2, 1), .Cells(2, MAXCOL)), "着手予定日")
        If CNT > 0 Then
            COL = .Rows(2).Find("着手予定日").Column

            '処理範囲を変数に格納
            Set area = .Range(.Cells(4, COL), .Cells(maxrow, COL))

            '範囲内に含まれるセルをループ処理
            For Each c In area
                c.Value = Mid(c.Value, 1, 8)
            Next
        Else: End If
    End With

    '画面描画ON
    Application.ScreenUpdating = True

    Cells(1, 2) = Now

End Sub

私の環境では、提示いただいたコードのままだと71秒/40万件でした。
これが参照範囲を変数に格納する対応のみ入れることで26~7秒/40万件となりました。
加えて画面描画OFFの対応も入れてみましたが、こちらも27秒前後とかわらず。
試しに画面描画OFFの対応だけでも動作させてみましたが、これは30秒前後と若干ですが差が出ました。

データ量によっては目に見えて差が出ることにもなりますので、できうる対応はしておいた方がよさそうですね。

参考になれば幸いです。

投稿

  • 回答の評価を上げる

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

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

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

  • 回答の評価を下げる

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

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

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

  • 2017/06/29 17:29

    jawaさん
    回答ありがとうございます。参考にさせて頂きます。

    キャンセル

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

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

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