« 2009年10月 | トップページ | 2009年12月 »

2009年11月の5件の記事

2009年11月28日 (土)

【改良】クイックソートを用いてアルファベットの文字列を並び替え

さらなる改良版はこちら(2010/01/17)。

今回は、先週紹介した並び替えのマクロを進化させました。

「words_ascending.dot」をダウンロード

先週紹介したサイトを読んでみたら、あれは、正式には
クイックソートではないらしいですね。

全ての文字列と順序を比較しているので、正式なクイックソート
よりも処理スピードが遅いと思います。

失礼いたしました。

僕も、他のクイックソートのプログラムに較べてあまりにも
シンプルで思考方法が違うので、少し不思議だなと思って
いたのですが、改良をしやすいので使わせてもらってました。

▼前回からの改善点
今回は、前回やりきれなかった以下の2点を改良しました。

①英単語(複数の単語の組み合わせ含む)の完全な並び替え
②大文字・小文字関係なく大小を比較

ついでに、用いる文字列を現在開いているワード文書から
読み込むようにしました。

記事の後半に記載されている「並び替え前後のサンプル」をご覧ください。

全角の文字列も含めて並び替えました。

おおよその並び替えのルールが見えると思います。

▼処理速度の例
ちなみに、2300ほどの英単語で並び替えをした場合に
私のパソコン(CPU: AMD Athlone 64 Processor 3000+ 2GHz,
メモリー: 1G, WinXP + Word2003) で55秒くらいかかりました。

同じことを、ワードの並び替え機能を使うと、1秒もかからずに
一瞬で並び替えてくれます。。。

もともと、このプログラムは、ユーザーフォーム中のリストボックスに
記載された80~100個の文字列の並び替えを目的としたものなので、
その程度の処理であれば、ストレスなく動くと思います。

多くの文字列の並び替えをする場合には、いちどワードの新規文書を開いて、
そこに全ての文字列をコピーしてからワードの機能の並べ替えを実行した方が
速いですね。

あんまりクイックではないソート(並び替え)です。

▼使い方
①インストールします。方法はこちら
②インストールしてアドインをオンにすると、[並び替え]という
 ボタンがツールバーに表示されます。
③開いている文書に、並び替えの対象となる文字列を記入します。
 (1行に1つの文字列を記入)
④[並び替え]ボタンをクリック

▼サンプル
【並び替え前】
300
情報
便利
お役立ち
販売
通販
blog
通信販売
Shopping
Shop
50
ヤフー
通信 販売
通信 販売
ブログ
1500
150
お気に入り

お買い物
検索
お得
デパート
web
Free
web2.0
tool
無料
book
free book
ニュース
進学塾
design
Search
中学受験
アニメ
ショッピング
SNS
映画
FC2
ホテル
DVD
予備校

【並び替え後】
1500
お気に入り
お得
お買い物
お役立ち
アニメ
ショッピング
デパート
ニュース
ブログ
ホテル
ヤフー
映画
検索

情報
進学塾
中学受験
通信 販売
通信販売
通信 販売
通販
販売
便利
無料
予備校
150
300
50
blog
book
design
DVD
FC2
Free
free book
Search
Shop
Shopping
SNS
tool
web
web2.0

▼プログラムの説明
(50行~90行)
開かれている文書に記載されている文字列を読み込みます。
案外、これも時間がかかります。

2300の文字列の場合に、31秒かかりました。
これって、時間かかりすぎ?

(200行~290行)
前回のプログラムでは、大文字のAと小文字のaとでは
別の文字として認識されていることがわかりました。

よって、今回は、Asc関数を用いて、文字コードを拾い出して、
それを変換して大文字と小文字とを比較するようにしました。

そういうわけで、処理がやたら面倒なことになっています。
たぶん、もっと簡単な方法があるんでしょうねぇ。

(10行、590行~610行)
Timer関数を使って時間を計測してみました。

▼プログラム
Sub QuickSortの例()

      Dim pCnt As Integer '段落数用の数値
      Dim pCntMax As Integer '段落の最大値
      Dim i As Long    '並び替え用の数値
      Dim j As Long    '並び替え用の数値
      Dim swap As String  '並び替え時の仮置き用変数
      Dim Chara() As String  '文字列
      Dim nMax As Integer '最大文字数
      Dim n As Integer    '比較する文字の序数
      Dim Chara_J As Integer '大文字を小文字の文字コードに変換
      Dim Chara_I As Integer '大文字を小文字の文字コードに変換
      Dim BlnSwap As Boolean '変更するか否かを示す
      Dim actDoc As Document '文書
      Dim StartT, FinishT, TotalT As Long  '時間計測用

10    StartT = Timer

20    Set actDoc = ActiveDocument

      '参照符号一覧の段落数
30    pCntMax = actDoc.Paragraphs.Count
40    ReDim Chara(1 To pCntMax)

      '文字列の読み込み
50    For pCnt = 1 To pCntMax
60        With actDoc.Paragraphs(pCnt).Range
70            Chara(pCnt) = Left(.Text, .Characters.Count - 1)
80        End With
90    Next pCnt

      'ソート開始
100   For i = 1 To pCntMax

110       For j = pCntMax To i Step -1
         
              '文字の大小の比較の最大回数を算出
              '少ない文字数を最大回数とする
             
120           If Len(Chara(i)) > Len(Chara(j)) Then
130               nMax = Len(Chara(j))
140               BlnSwap = True
150           Else
160               nMax = Len(Chara(i))
170               BlnSwap = False
180           End If
             
              'n番目の文字同士を文字コードを用いて大小を比較
             
190           For n = 1 To nMax
             
                  'アルファベットの文字コードを取得し、
                  '大文字の場合、対応する小文字の文字コードに変換
                  
                  'Chara(i)の場合
200               If Asc(Mid(Chara(i), n)) >= 65 And _
                     Asc(Mid(Chara(i), n)) <= 90 Then
210                   Chara_I = Asc(Mid(Chara(i), n)) + 32
220               Else
230                   Chara_I = Asc(Mid(Chara(i), n))
240               End If
                  
                  'Chara(j)の場合
250               If Asc(Mid(Chara(j), n)) >= 65 And _
                     Asc(Mid(Chara(j), n)) <= 90 Then
260                   Chara_J = Asc(Mid(Chara(j), n)) + 32
270               Else
280                   Chara_J = Asc(Mid(Chara(j), n))
290               End If
                  
                  'n文字目のアルファベットの比較
                  
                  'Chara(i)がChara(j)より大きい場合
300               If Chara_I > Chara_J Then
                  '順番を入れ替える
310                   swap = Chara(i)
320                   Chara(i) = Chara(j)
330                   Chara(j) = swap
340                   Exit For
                  
                  'Chara(i)がChara(j)より小さい場合
350               ElseIf Chara_I < Chara_J Then
                  '順番を入れ替えない
360                   Exit For
                  
                  'Chara(i)とChara(j)が同じ場合 かつ
                  'nが比較を繰り返す最大回数nMaxになっても
                  '文字の大小の比較が終わっていない場合
370               ElseIf n = nMax Then
                  
                      'Chara(i)の文字数がChara(j)の文字数より多い場合
380                   If BlnSwap = True Then
390                       swap = Chara(i)
400                       Chara(i) = Chara(j)
410                       Chara(j) = swap
420                       Exit For
                  
                      'Chara(i)の文字数がChara(j)の文字数以下の場合
430                   Else
440                       Exit For
450                   End If
                  
460               End If
             
470           Next n
             
480       Next j

490   Next i

      '並び替え後を表示

500   With actDoc
510       .Range(.Range.End - 1, .Range.End - 1).InsertParagraphAfter
520       .Range(.Range.End - 1, .Range.End - 1).Text = "【並び替え後】"
530       .Range(.Range.End - 1, .Range.End - 1).InsertParagraphAfter

540       For i = 1 To pCntMax
550           .Range(.Range.End - 1, .Range.End - 1).Text = Chara(i)
560           .Range(.Range.End - 1, .Range.End - 1).InsertParagraphAfter
570       Next i
580   End With

590   FinishT = Timer
600   TotalT = FinishT - StartT

610   MSGBOX TotalT & "秒かかりました。"

End Sub

| | コメント (0) | トラックバック (0)

2009年11月21日 (土)

クイックソートを用いてアルファベットの文字列を並び替え

こちらに改良版を紹介しています。ご覧ください。

プログラム業界では、クイックソートという考え方があるそうです。

今回紹介するプログラムは、クイックソートを利用した
アルファベットの並び替えの例です。

▼背景
リストボックスに書かれた文字列をアルファベット順に並び替えるための
サンプルマクロを探していたら「クイックソート」という言葉に出会いました。

Excel VBA 実用サンプルコレクション」の407ページに
言葉だけ書かれており、ネットで検索しました。

リストボックスの文字列を並び替える場合には、
一旦リストボックスに書かれた配列を取り出して
並び替えた後に、再度リストボックスに書き込む
プログラムにします。

以下のサンプルでは、Chara()という配列が
10行から100行にて定義されています。

▼参考にしたページ
エクセルVBAの書籍をたくさん書かれており、また
セミナーも行っている田中亨さんのOffice Tanakaです。

「クイックソート」で検索すると様々なページがありましたが、
このページに書かれたコードが短くて美しいと思ったので参考にしました。

また、クイックソート以外にも、VBAに関する情報がたくさん載って
いますので、非常に役に立つサイトだと思います。

▼並び替え結果例
【並び替え前】
apple
people
connector
3
an
condition
Ai
third
200
a

【並び替え後】
200
3
Ai
a
an
apple
condition
connector
people
third

▼工夫
アルファベットの大小を比較するために、アスキーコード
にて大きさを比較しました。

170行~300行にて、2文字目までを比較するようにしました。

そのために、上記の例の通り、3文字目以降から文字がかわる
conditionとconnectorとは、正確に並び替えることができません。

また、アスキーコードの場合には、大文字と小文字とで
別々の数値が指定されているので、それも考慮した方が
よりよい並び替えになりますね。

もっと簡単な考え方をご存じの方がいらっしゃったら
教えてください。

▼プログラム
Sub QuickSortの例()

      Dim i As Long    '並び替え用の数値
      Dim j As Long    '並び替え用の数値
      Dim msg As String  'メッセージ
      Dim swap As String  '並び替え時の仮置き用変数
      Dim Chara(1 To 10) As String  '文字列

10    Chara(1) = "apple"
20    Chara(2) = "people"
30    Chara(3) = "connector"
40    Chara(4) = "3"
50    Chara(5) = "an"
60    Chara(6) = "condition"
70    Chara(7) = "ai"
80    Chara(8) = "third"
90    Chara(9) = "200"
100   Chara(10) = "a"

      'ソート前の文字列を取得
110   msg = msg & "【並び替え前】" & vbCrLf

120   For i = 1 To 10
130       msg = msg & Chara(i) & vbCrLf
140   Next i

      'ソート開始
150   For i = 1 To 10

160       For j = 10 To i Step -1
               
               '1文字目が同じアルファベットだったとき
170            If String(1, Chara(i)) = String(1, Chara(j)) Then
                  
                  '2文字目の比較(ケース1)
180               If Mid(Chara(i), 2) <> vbNullString And _
                     Mid(Chara(j), 2) <> vbNullString Then
190                   If String(1, Mid(Chara(i), 2)) > String(1, Mid(Chara(j), 2)) Then
200                       swap = Chara(i)
210                       Chara(i) = Chara(j)
220                       Chara(j) = swap
230                   End If
240               End If
                  
                  '2文字目の比較(ケース2)
250               If Mid(Chara(i), 2) <> vbNullString And _
                     Mid(Chara(j), 2) = vbNullString Then
260                   swap = Chara(i)
270                   Chara(i) = Chara(j)
280                   Chara(j) = swap
290               End If

300           End If
             
              '1文字目が違うアルファベットの時
310           If String(1, Chara(i)) > String(1, Chara(j)) Then
320               swap = Chara(i)
330               Chara(i) = Chara(j)
340               Chara(j) = swap
350           End If
             
360       Next j
370   Next i

      'ソート後の文字列を取得
380   msg = msg & "【並び替え後】" & vbCrLf
390   For i = 1 To 10
400       msg = msg & Chara(i) & vbCrLf
410   Next i

      '結果を表示
420   msgbox msg

End Sub

| | コメント (0) | トラックバック (0)

2009年11月14日 (土)

【再再改良】フォルダ中のすべてのワードファイルの内容をコピペする

さっそく、とんちんかんさんからいただいたファイルをご紹介します。

「copy_paste_4.dot」をダウンロード (ワード2003用)
「copy_paste_4_2007.dot」をダウンロード (ワード2007用)

とんちんかんさん、どうもありがとうございました。

使い方やインストール方法や改良の経緯は、下記をご覧ください。

2009/11/11 【再改良】フォルダ中のすべてのワードファイルの内容をコピペする

2009/06/06 【改良】フォルダ中のすべてのワードファイルの内容をコピペする

2009/05/23 フォルダ中のすべてのワードファイルの内容をコピペする

▼使うための設定
こちらを参考にして、Microsoft Scripting Runtimeをオンにしてください。

今回のマクロでは、ファイルシステムオブジェクトを使っています。

word2007に対応しなくなったFileSearch メソッドをファイルシステムオブジェクト
を用いて定義しているからです。

細かいことは、できる大辞典 Excel VBAの485ページをご覧ください。

実は、私、ファイルシステムオブジェクトについてよくわかっておりません。

▼留意点
パソコンのセキュリティ設定によっては、スクリプトの書き込みの
警告メッセージが出ることがあると思いますが、
疑わしい設定ではなく、意図的に行っております。

Copypaste4

上の画像は、私のパソコンにインストールしてある
ウィルスセキュリティが反応して警告メッセージを
表示した状態を示します。

この状態で、「すべて許可」、「今回は許可」の
いずれをクリックしても問題はないと思います。

対処方法は、ウィルスセキュリティの公式サイトをご覧ください。

なお、「停止」をクリックすると、マクロが終了します。

これは、Private Sub FileSearch2007_Repeatのマクロの
エラー時の処理 err = 438 に対応しています。

▼このファイルの特徴
1.Word2007で動きます
2.指定フォルダのサブフォルダまで『ワードファイル』を探し続けます。
  (サブフォルダ検索の要否はメッセージボックスで選択可)
3.読み取り専用設定ファイルを閉じるときの確認メッセージが表示
  されないようにしました。
4.すべてのファイルを読み取り専用で開きます。
  (内容の変更がないように、念のため。)

▼用途
フォルダに保存された複数のファイルを表示する必要がある場合に、
非常に重宝します。

100個くらいファイルがあると、クリックして開くだけでも
時間がかかります。

また、フォルダが複数ある場合には、余計手間ですね。

このマクロを作成した今年の5月の時点では、特定の用途は
想定しておりませんでした。

このたび、とんちんかんさんが業務にてご活用されていることを
教えていただき、非常にうれしく思います。

▼工夫
Word2007では、FileSearch メソッドが機能しないようです。
とんちんかんさんが、いろいろと調べて、それに対応する
word2007版の方法を作成してくれました。

Functionとして定義しています。

実は、難しくて、自分では理解できていませんが、
ひとまず動くので紹介します。

おそらくとんちんかんさんが参照されたページはこちらです。

とんちんかんさんからいただいたプログラム文に、私が
多少手を加えて、サブフォルダまでファイルを取りにいくのか否か
の選択ができるようにしました。

誤動作がある場合はご連絡ください。

とりあえず、word2007の運転確認は私はできないのですが、
おそらく動くだろうと思うファイルを公開しています。

▼ワードのバージョンにあわせた修正方法
Sub コピペ_2003_2007()のマクロの190行目を変更することで、
word2007とword2003とを切替えています。

要は、ワード文書の拡張子を切替えているんですね。

| | コメント (3) | トラックバック (0)

2009年11月11日 (水)

【再改良】フォルダ中のすべてのワードファイルの内容をコピペする

先日、こちらのページにとんちんかんさんからいただいたご質問への回答です。

ファイル名の着色と文字サイズの変更をしました。
「copy_paste_3.dot」をダウンロード

以下、とんちんかんさん仕様のプログラムです。

基本的には、上記のテンプレートのものと同じですが、橙色文字部分だけ
とんちんかんさん用に変更しました。

310行以降のfor next文を取り出しています。

380行~420行に、フォントのサイズと色の設定があります。

コピペ2のプログラムでは、rangeオブジェクトでコピペを実行
していました。

今回のように、フォントに着色をしたりフォントのサイズを
変更したりするためのrangeオブジェクトのプロパティが
よくわかりませんでした。

結果、selectionオブジェクトを用いてご要望のことを実現しました。

とんちんかんがご指摘の通り、
selection.font.colorと
selection.font.size
を用いています。

お試しください。

310   For i = 1 To FC
         
320       With Documents.Open(FileName:=varTMP(i), Visible:=False)
330           .Content.Copy
340           .Close
350       End With
         
          'ファイル名の入力位置へカーソルを移動(文書の末尾へ)
360       Selection.Start = actDoc.Range.End - 1
370       Selection.End = actDoc.Range.End - 1
         
          'ファイル名の着色
380       With Selection
390           .Font.Color = wdColorRed
400           .Font.Size = 14
410           .TypeText Text:= "氏名管理番号 : " & varNam(i)
420       End With
         
430       Selection.TypeParagraph
440       Selection.TypeParagraph
             
          'コピー内容の貼り付け
450       Selection.Paste
         
          '最後の文書でなければ、改ページをする
460       If i <> FC Then
470           Selection.InsertBreak Type:=wdPageBreak
480       End If
         
490   Next i

| | コメント (0) | トラックバック (0)

2009年11月 8日 (日)

マクロインストーラーの更新

すでにお気づきの方もいらっしゃったかと思いますが、
以前こちらで紹介したマクロインストーラーを更新いたしました。

ベクターにてインストーラーを公開しております。
使用方法も書かれていますので、ご覧ください。

【前回からの主要な変更点】
インストールするマクロテンプレートを、ダイアログから
指定できるようになりました。

テンプレートフォルダ中の「Normal.dot」ファイルが
表示されないようにしました。(このファイルを移動
したり削除したりすると、現在のワードの設定が
消えてしまいます。今までは、その配慮が足りませんでした。)

お試しください。

| | コメント (0) | トラックバック (0)

« 2009年10月 | トップページ | 2009年12月 »