[[20140725102515]]　『VBA ２文字置きに区切る処理を高速で行いたい』（tamayan）　ページの最後に飛ぶ

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

　

『VBA ２文字置きに区切る処理を高速で行いたい』（tamayan）

こんにちは。ネットで調べてもわからなかったので質問お願いします。

エクセルのA列に6000行ほど以下の感じで文字列が入っています。
(実際の文字数はこれより多いです。）

1　FSFWFEFE 1 1 1 1 113 1 1 3FSFSFSFA
2　FGFCFMFE 1 1 1 1 1 115 1 1FGFCFMFE
3　FSFSFSFA 1 1 1 1 1 1 117 1FSFWFEFE 

				↓
この文字列を２文字置きに区切って以下のようにしたいのですが


   A  B  C  D  E  F  G  H  I  J  K  L  M  N  O  P  Q	     
1　FS|FW|FE|FE| 1| 1| 1| 1| 1|13| 1| 1| 3|FS|FS|FS|FA
2　FG|FC|FM|FE| 1| 1| 1| 1| 1| 1|15| 1| 1|FG|FC|FM|FE	
3　FS|FS|FS|FA| 1| 1| 1| 1| 1| 1| 1|17| 1|FS|FW|FE|FE

マクロの記録で区切り位置指定をしたところ以下のコードになりました。

Sub kugiri()
ActiveSheet.Columns(1).select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(2, 1), Array(4, 1), Array(6, 1), _
Array(8, 1), Array(10, 1), Array(12, 1), Array(14, 1), Array(16, 1), _
↓↓省略
Array(688, 1), Array(690, 1)), TrailingMinusNumbers:= True
End Sub

このコードを実行すると２文字おきに区切れるのですが、処理時間が10秒ほどかかってしまいます。
（画面非表示の設定をしても10秒ほどかかります。）

処理時間を短縮するコードをご存知でしたら、教えていただけないでしょうか。
よろしくお願いいたします。

＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞ 

 私のパソコンでは、1400文字（Array690*2≠約1400）を6000行をこなすと、30秒くらいかかりました・・・


 不備があったので取り下げます・・・
 1652
（稲葉） 2014/07/25(金) 16:47

 約7000行で3秒足らず...


 Sub test()
    Dim a, i As Long, ii As Long, temp, s As Single
    s = Timer
    With Cells(1).CurrentRegion
        a = .Value
        ReDim Preserve a(1 To UBound(a, 1), 1 To 100)
        With CreateObject("VBScript.RegExp")
            .Global = True
            .Pattern = ".{2}"
            For i = 1 To UBound(a, 1)
                temp = a(i, 1)
                For ii = 0 To .Execute(temp).Count - 1
                    a(i, ii + 1) = .Execute(temp)(ii)
                Next
                If Len(temp) Mod 2 Then a(i, ii + 1) = Right(temp, 1)
            Next
        End With
        .Resize(, 100).Value = a
    End With
    MsgBox Timer - s
End Sub
（seiya） 2014/07/25(金) 20:05
seiyaさん

教えていただきありがとうございました！
6秒近く短縮できました。大満足です。

本当にありがとうございましたm(__)m
（tamayan） 2014/07/25(金) 23:41

すみません、もう一度お願いします。。。

seiyaさんから教えて頂いたコードを今日実際のファイルで試してみたところ
90秒近くかかってしまいました。自分の説明が足りなかったのですが、
実際に使用したいファイルは6000行で1行あたり平均で430文字入っています。
（文字が一番少ない行で280文字、一番多い行で480文字です。）

自分が最初の質問欄に記載した例文だと7000行でも0.9秒という早さで処理が完了したのですが、
文字数が多くなるとやはり時間がかかってしまうのでしょうか？

またseiyaさんのコードを参考にして、セルB1以降に書き込んでいくマクロコードを作成してみました。
処理速度は約17秒でした。5秒以内が目標です。
添削の程、よろしくお願い致します。

*********************************************************

Sub TEST2()

Dim sOrg As String
Dim i, ii As Long
Dim z As String
Dim Mrow As Long
Dim t As Single

t = Timer

Application.ScreenUpdating = False
Application.EnableEvents = False

With Worksheets(1) 

    Mrow = .Cells(Rows.Count, 1).End(xlUp).Row


    For ii = 1 To Mrow
    z = 1
        If .Cells(ii, 1).Value <> "" Then
            sOrg = .Cells(ii, 1).Value
            For i = 1 To Len(sOrg) Step 2
                .Cells(ii, 1).Offset(0, z).Value = Mid(sOrg, i, 2)
                z = z + 1
            Next i
        End If
    Next ii
End With

Application.ScreenUpdating = True
Application.EnableEvents = True

MsgBox Timer - t
End Sub
（tamayan） 2014/07/28(月) 14:17 

 １セルの文字数800, 9000行で　6,7秒


 Sub test()
    Dim a, i As Long, ii As Long, temp, n As Long, s As Single
    s = Timer
    With Cells(1).CurrentRegion
        a = .Value
        ReDim Preserve a(1 To UBound(a, 1), 1 To 1000)
        For i = 1 To UBound(a, 1)
            If Len(a(i, 1)) Then
                temp = a(i, 1): n = 0
                For ii = 1 To Len(a(i, 1)) Step 2
                    n = n + 1
                    a(i, n) = Mid$(temp, ii, 2)
                Next
            End If
        Next
        .Resize(, 100).Value = a
    End With
    MsgBox Timer - s
End Sub
（seiya） 2014/07/28(月) 14:51
seiyaさん

ありがとうございます！
教えていただいたコードで実行したら2.3秒で処理が終わりました。
本当にありがとうございました。m(__)m
（tamayan） 2014/07/28(月) 16:27

 訂正


 >.Resize(, 100).Value = a
 は
 >.Resize(, 1000).Value = a


 このサイズは未確定なので400 とか 500 で調整してください
（seiya） 2014/07/28(月) 16:32
コメント返信：

[ 一覧(最新更新順) ]

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