特価データを何とかしなければ・・・。

あるメーカーでは特価を後値引き方式で対応しています、その売上データの申請を一手に任されているのですが客先個別の特価自体の新規申請はそれぞれの担当営業がやっています。

客先別の特価一覧表が毎月送られてくるので全営業と女性業務に転送しています、その表には特価の適用開始日、終了日、猶予期間が記載されていて終了日を過ぎても猶予期間中は特価が適用されます、ところが誰一人その部分を見ていないのです。

特価が適用されなくなって初めて慌てるのが現状、自分の客なのだから少なくとも猶予期間中に再申請なり延長を申請すべきなのだがそれをしていないのです、これは営業からしかできないことなので何とかしなければと前々から思っていました。

別のあるメーカーも同様でこのメーカーに関しては特価の履歴を色分けしてそれと分かるようにするマクロを組んで結果だけをエクセルデータで配布しています、このメーカーのデータはテキストデータなので扱いやすかったので早くからそうしていました。

ところが冒頭のメーカーのそれはエクセルデータで余計なヘッダや結合セルなんかがあって扱いにくくでやる気が起きなかったのです、でもここに来てそうも言っていられなくなり先週あたりからマクロを組み始めました。

方法として・・。

・新しいデータをブックを開かずに抽出して現行データに追加する。
・客先、型番、猶予期間でソート。
・重複データの猶予期間の新しいものと古いものを色分けする。
・結果をマクロを含まない別ブックとして出力する。

以上のことを目論んでいます。

ちょっと便利に

Sub Google_Search()
'改良版、単一セルだけではなく複数セルに対応
　　For Each nh In Selection
　　　　i = i & nh & " "
　　Next nh
　　i = Replace(i, " ", "+")
　　CreateObject("Wscript.shell").Run _
　　　　"http://www.google.co.jp/search?q=" & i, 1
End Sub


「Excelで検索」で書いたマクロ、昨日使っていてもうちょっと便利にならないかなと考えました、複数のセルの文字列を一度で取り込みたいのですがこのままではだめ。

具体的に何をしたいかと言うと、、

A列　　　　　　　　B列
1Jimi Hendrix　　Spanish Castle Magic
2　　　　　　　　　　Hey Joe
3　　　　　　　　　　Foxy Lady

こんな並びの表があった場合「A1+B1」あるいは「A1+B2」というように「Ctrlキー」を押しながら検索キーワードを取り込みたいと思ったわけです。

そしてできたのが冒頭のマクロ、なかなか使い勝手が良いです。

遅いマクロと速いマクロ

昨年8月21日から今年の8月20日まで一年間のあるメーカーの売上データの中で数種類の特定商品だけを抽出しなければなりません、そのためにまず頭に浮かんだのが「オートフィルター」、でもこれ、条件が二つしか指定できないのが難点です。

何月にどの商品がどのくらい売れたのか、これは「ピボットテーブル」で簡単に分かります、いきなりそれをやって必要なアイテムを反映させればいいのですがアイテム数は数千種類にも及ぶのです、困ったことに「ピボットテーブル」は不要なアイテムのチェックをはずして行くやり方しかできないのです、一度全部チェックを外して再度必要なアイテムにチェックを入れるということができないのです。

そこで必要なアイテムだけを抽出してそれを基にピボットテーブルを作る必要があります、これはマクロの出番、始めに作ったのが「対象データ抽出A」で不要なアイテムを削除していきます、これを走らせて見たら5分以上もかかります、62,464行ものデータがありしかもWindows2000、Excel2000、セレロンPCだから仕方ないかと思いましたがあまりにも遅すぎます。

そこで考え方を変えて必要なデータだけを別のシートにコピーするというやり方で作ったのが「対象データ抽出B」、これを走らせたら何と「7秒！」でできてしまいました、あまりの速さに力が抜けてしまいました、何なんだこの差は？

Sub 対象データ抽出A()
With Application
　　.ScreenUpdating = False
EndRw = Cells(Rows.Count, 1).End(xlUp).Row
For i = EndRw To 2 Step -1
　　If Cells(i, 7) ＜ 0 Then
　　　　Rows(i).EntireRow.Delete
　　End If

　　Set c = Cells(i, 2)

　　If c.Value <> "文字列A" And c.Value <> "文字列B" And _
　　　　c.Value <> "文字列C" And c.Value <> "文字列D" And _
　　　　c.Value <> "文字列E" And c.Value <> "文字列F" And _
　　　　c.Value <> "文字列G" And c.Value <> "文字列H" And _
　　　　c.Value <> "文字列I" And c.Value <> "文字列J" And _
　　　　c.Value <> "文字列K" And c.Value <> "文字列L" And _
　　　　c.Value <> "文字列M" And c.Value <> "文字列N" And _
　　　　c.Value <> "文字列O" And c.Value <> "文字列P" And _
　　　　c.Value <> "文字列Q" And c.Value <> "文字列R" And _
　　　　c.Value <> "文字列S" And c.Value <> "文字列T" Then
　　　　　　Rows(i).EntireRow.Delete
　　ElseIf Left(Right(c.Value, 4), 2) = "PN" Then
　　　　Cells(i, 7) = Cells(i, 7) * Right(c.Value, 2)
　　　　Cells(i, 8) = Cells(i, 8) / Right(c.Value, 2)
　　　　c.Value = Replace(c.Value, Right(c.Value, 4), "")
　　End If
Next i
EndRw = Cells(Rows.Count, 3).End(xlUp).Row
For i = 2 To EndRw
　　Set d = Cells(i, 3)
　　d.Value = d.Value + 19000000
Next i
　　　　　　Columns(3).TextToColumns _
　　　　　　DataType:=xlDelimited, _
　　　　　　textqualifier:=xlDoubleQuote, _
　　　　　　fieldinfo:=Array(1, xlYMDFormat)
　　.ScreenUpdating = True
End With
End Sub

Sub 対象データ抽出B()
With Application
　　.ScreenUpdating = False
　　j = 1
　　For i = 1 To Sheets("uriage").Cells(Rows.Count, 1).End(xlUp).Row
　　　　Set c = Sheets("uriage").Cells(i, 2)

　　　　If c.Value = "文字列A" Or c.Value = "文字列B" Or _
　　　　　　c.Value = "文字列C" Or c.Value = "文字列D" Or _
　　　　　　c.Value = "文字列E" Or c.Value = "文字列F" Or _
　　　　　　c.Value = "文字列G" Or c.Value = "文字列H" Or _
　　　　　　c.Value = "文字列I" Or c.Value = "文字列J" Or _
　　　　　　c.Value = "文字列K" Or c.Value = "文字列L" Or _
　　　　　　c.Value = "文字列M" Or c.Value = "文字列N" Or _
　　　　　　c.Value = "文字列O" Or c.Value = "文字列P" Or _
　　　　　　c.Value = "文字列Q" Or c.Value = "文字列R" Or _
　　　　　　c.Value = "文字列S" Or c.Value = "文字列T" Then
　　　　　　Rows(j) = c.EntireRow.Value
　　　　　　Cells(j, 3).Value = Cells(j, 3).Value + 19000000
　　　　　　Set d = Cells(j, 2)
　　　　　　If Left(Right(d.Value, 4), 2) = "PN" Then
　　　　　　　　Cells(j, 7) = Cells(j, 7) * Right(d.Value, 2)
　　　　　　　　Cells(j, 8) = Cells(j, 8) / Right(d.Value, 2)
　　　　　　　　d.Value = Replace(d.Value, Right(d.Value, 4), "")
　　　　　　End If
　　　　　　If Cells(j, 7) <0 Then<br>
　　　　　　　　Rows(j).EntireRow.Delete
　　　　　　　　j = j - 1
　　　　　　End If
　　　　　　j = j + 1
　　　　End If
　　Next i
　　With Columns(3)
　　　　.TextToColumns _
　　　　　　DataType:=xlDelimited, _
　　　　　　textqualifier:=xlDoubleQuote, _
　　　　　　fieldinfo:=Array(1, xlYMDFormat)
　　　　.AutoFit
　　End With
　　.ScreenUpdating = True
End With
End Sub

入力規則

「注文書」と「見積り依頼書」兼用の帳票があります、「入力規則」を設定してあり、あて先および直送先を選べます、そしてあて先、直送先を変えると「VLOOKUP関数」によって「気付欄」の個人名もそれなりに変わります。

それなりに重宝に使ってもらっていますが先日こんな依頼がありました。

特に直送先に関してですが客先によっては担当者（窓口）が複数いるところがあるので客先によって「気付欄」もプルダウンによって担当者を選択したい、というものでした。

そんなのわけない、範囲名を付け「INDIRECT関数」で・・・・とやり始めたら意外と曲者・・・・・・・。

「気付欄」に表示されるリストに範囲名を付ける、その範囲名は直送先の会社名そのものとすれば重複は避けられる、だがことはそう容易く運ばないのです。

たとえば

（株）のんち電機　さいたま営業所

なんてのがありそのまま範囲名にしようとするとエラーになるのです、そう、記号は使えないのです、また空白もだめ、会社が休みの日、あの鬼のように暑い我が家の2階でしばらく考えたのです頭が働かない、というわけで今朝職場にきて閃きました。

こんなことはできないかと・・・・・。

「SUBSTITUTE関数」を使って記号と空白を詰め、それを「INDIRECT」する、これが見事に図に当たりました、上の例でいうと、

「（株）のんち電機　さいたま営業所」を「株のんち電機さいたま営業所」と詰めてこれを範囲名にするのです。

詰める文字は、全角の左右の括弧、半角の左右の括弧、全角と半角の空白の6種類、「元の
値」欄に

=INDIRECT(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE($A$1,"（",""),"(",""),"）",""),")",""),"　","")," ",""))

と入れました。

本当は括弧つきの株と有も詰めたかったのですが関数のネストは7個までという制約上括弧つきの株までは入るがそれでは片手落ちなので6個にしたのです。

新規にデータを作るときに括弧つきの株と有は使わないようにしてもらうつもりです。

（株）や（有）を詰めればいいと思うかもしれませんがプロポーショナルフォントだと見た目があまり変わらず入力した人間はそんなことまるで意識しないので左側の括弧が全角で右側のそれが半角なんてのは十分あり得るのです、そんなことを考えてこんな風にしたわけです。

CSVを指定行数で別ブック保存

「膨大な商品マスタをなんとかしなければ。」で

> データ量を指定することで別ブックで出力するようなマクロを組むこと

と書きましたけど何とか出来ました。

1ページ（シート）で済む場合はすんなりそのまま全データを読めばよく、問題は2ページ（シート）以上になるとき、1ページ目で読んだ分を飛ばしてその次から読む必要があります、その場合「.Skip」というメソッドがあるのでいろいろ試行錯誤、というか実際は錯誤錯誤の連続だったのですが、「.Skip」メソッドは読みたい行を指定して読むときに使うもので全て読む場合は不要、結局はファイルをオープンしたら指定行分読み込んでページ（シート）を変えればすむことでした。

当初シートを増やして全て読み込んでから各シートをブックとして保存しようかとも思いましたがそれをやるとおそらくメモリ、システム・リソース不足でハングアップは必至、そんなわけで1シート分読み込んだらその都度別ブックで保存する形にしました。

Sub CSVを指定行数で別ブック保存()
Dim 読込ファイル As String, パス As String
Dim バッファ As String, EndRow As Long, Msg As String
Dim Ans As String, i As Long, j As Long, Pg As Long

With Application
　　.ScreenUpdating = False
　　読込ファイル = Application.GetOpenFilename _
　　　　(FileFilter:="CSVファイル(*.csv),*.csv", _
　　　　MultiSelect:=False)
　　If 読込ファイル <> "False" Then
　　パス = CurDir & ""
　　Set Obj = CreateObject("Scripting.FileSystemObject")
　　With Obj.OpenTextFile(読込ファイル, 1)
　　　　　　バッファ = .ReadAll
　　　　　　.Close
　　End With
　　EndRow = UBound(Split(バッファ, vbCrLf)) '最終行を取得
　　Msg = EndRow & " 行あります。" & _
　　　　　Chr(10) & "何行ごとに分割しますか？"
　　Ans = InputBox(Prompt:=Msg, Default:="65535")
　　If Ans = "" Then Exit Sub
　　Pg = Int(Abs(EndRow / Ans) * -1) * (Sgn(EndRow / Ans) * -1)

　　With Obj.OpenTextFile(読込ファイル, 1)
　　　　For i = 1 To Pg
　　　　　　Cells.ClearContents
　　　　　　If i = Pg Then Ans = EndRow - (Ans * (i - 1))
　　　　　　For j = 1 To Ans
　　　　　　　　バッファ = .ReadLine
　　　　　　　　バッファ = Replace(バッファ, """", "")
　　　　　　　　tmp = Split(バッファ, ",")
　　　　　　　　Range(Cells(j, 1), Cells(j, UBound(tmp) + 1)) = tmp
　　　　　　Next j

　　　　　　ActiveSheet.Copy
　　　　　　With ActiveWorkbook
　　　　　　　　.SaveAs パス & "データ_" & i
　　　　　　　　.Close
　　　　　　End With
　　　　　　If i = Pg Then GoTo Fin
　　　　Next i
Fin:
　　　　　　.Close
　　End With
　　Set Obj = Nothing
　　End If
　　Cells.ClearContents
　　.ScreenUpdating = True
End With
End Sub

それとページ(Pg)数を整数で切り上げるのにちょっと考えました、その部分は取り敢えず拝借、ひとつひとつよーく考えると分かったような気がするのですが説明が出来ません。

Office2010の「スクリーン・ショット」

この前の休みに「たけしくん、ハイ！」のDVDを作ったときに画像をラベル面に印刷しようとしてwebを探し回ったのですが見つからなくてPCで再生してそのハード・コピーを取り、Excelに貼ってトリミングしようとしたけどどうしても出来ないのです。

ところが今度のOfficeには「スクリーン・ショット」なる新機能が付いています、なんか使える、まだ体験版だけどこれでいとも簡単にDVDのラベルが出来ちゃいました。

お絵かきソフトがあれば同じことが出来るでしょうけどやたら高いし、フリー・ソフトでは「GIMP」なんてのがあってかなり高機能らしいですがやりたいことをどこをどうすれば出来るのかが分かりません。

Office2010は起動も早いし動作も軽い、買っちゃおうかなぁ。

いつまでもベータ版が使えるわけでもないし。

シートだけを別ファイルとして保存する。

メーカーから電送される商品マスタや特価データの差分を反映して社員に配布していますが以前から不安に思っていることがあります、VBA（マクロ）もそのまま送っていてファイルを開くと自動でメニューが出るのですがこのメニュー、自分しか使うことのないメニューなんです。

受け取った人間がそのメニューを操作して変なことにならないか心配なのです、そこでデータが反映されたシートだけを別ファイルとして保存して配布する方法を模索していたら割合簡単に出来てしまいました、出来たファイルのサイズは当然とても小さくなります。

Sub 結果を別ファイルで保存()
　　パス = "C:........"
　　名前 = "特別価格" & Format(Date , "yyyymmdd")
　　Sheets("Sheet1").Copy
　　With ActiveWorkbook
　　　　.SaveAs パス & 名前
　　　　.Close
　　End With
End Sub

こんな感じ・・・。

一番下の行を知るには・・・。

データがいくつあるのかを知るためにいつも・・・

データ = Cells.CurrentRegion.Rows.Count

と記述していました。

実はこの記述、列が隣接していてかつ、歯抜けがない、つまりデータが連続している列の最下行をを求める記述でした、今まですべてデータが連続しているものばかりを取り込んでいたので、また列によってデータ量が変わらないデータだけを扱っていたのでちゃんと動いていたのです。

今回歯抜けはないが列ごとにデータ量が変わるデータを扱う必要が生じ列ごとに最下行を知る必要が出てきて冒頭の記述では役に立たないことが分かったのです。

そこで苦肉の策として・・・

データ = Application.CountA(Range(列)) - 1

これでもいいと思うのですがなんか気に入らないのです、そこでいろいろ調べたらいろいろ方法はあるようですが・・・

1.最終行 = Range("A1").End(xlDown).Row
2.最終列 = Range("A1").End(xlToRight).Column
3.最終行 = Range("A65536").End(xlUp).Row
4.最終列 = Range("IV1").End(xlToLeft).Column ' IV1=256列
5.最終行 = Cells(Rows.Count, 1).End(xlUp).Row
6.最終列 = Cells(1, Columns.Count).End(xlToLeft).Column

With Range("A1").SpecialCells(xlLastCell)
最終行 = .Row
最終列 = .Column
End With

With ActiveSheet.UsedRange
最終行 = .Rows.Count
最終列 = .Columns.Count
End With

With ActiveSheet.UsedRange
最終行 = .Rows(.Rows.Count).Row
最終列 = .Columns(.Columns.Count).Column
End With

結局、行は(5)が、列は(6)が一番確実みたいですね、これならばエクセルの2007や2010でもそのまま動くはずです。

データ = Cells(Rows.Count, 列).End(xlUp).Row

つまり Cells(シート全体)の何列目のRows.Count(行数)まで一番下から上に向かって[End]+[Up]キーを押したと同じことです。

今まで作ったやつの「Cells.CurrentRegion.Rows.Count」部分をみんな直さなくちゃ、あーあ面倒。

PS.
実際は一番右の列と一番下の行は検出できないことが分かりました、でもExcelでそれほどの大量のデータを扱うことはまずないでしょう。

納短依頼のフォーマット

納短依頼

件のメーカー用に「納期短縮」「注文取消」「キャンセル申請A」「キャンセル申請B」という用紙がエクセルでそのメーカーから配布されていてそれを私が使い勝手を考えて便利に使えるようにして皆に使ってもらっています。

それぞれ別々のエクセルファイルだったのですがどれも同じデータが基になっています、それじゃあ一つのファイルにしてそこから上記全てを出力できないかと思いました。

要はその帳票が必要とする項目を元のデータから切り貼りすればいいわけだから・・、というわけで時間はかかりましたが何とか暫定版を作ってダメ出しを依頼中です。

もちろん使いやすいようにフローティング・メニューにしましたが最も神経を注いで作ったのが「環境設定」、これに使う元のデータをメーカーのEDIから引っ張ってきて「どこか」に保存するわけですが我々のような古い人間はPCと言えば「DOS」でしたからディレクトリ、今で言うところのフォルダの概念を理解できなければ何もできませんでした。

windows 以降にPCに携わりはじめた人にとってはこれに「ショートカット」なんて概念も入ってきたので話がややこしくなってきます、要は「どこでもドア」みたいなもので奥深く潜り込んだ場所へ直行できる入り口とでも言えばいいでしょう、でもエクセルに限らずどのアプリケーションもそうですがたとえwindowsであれ「絶対パス」が必須なことには変わりありません。

それまでは「環境設定」のメニューボタンを押すと使う人の名前とデフォルトでファイルを読みに行く場所を聞くようにしてありました、ドライブは「C：」に固定して面倒を避けていたのですがそれでも初めて使うときは結局脇で操作を助けてやることが多かったのです。

今までのものは下図のようにまず名前を登録し、次に同様のダイアログで場所を入れるのですがここで止まって先へ行けない人の方が多いのです。



そこでこれなら誰でも分かるだろうと次の図のようなダイアログを出すようにしました、これは WindosScript っていうものらしいです、でも引数の詳細が全て分からないのです、事実この図のような「新しいフォルダ」は引数リストになかったのです。



そこで適当に引数の数字を変えていってやっと見つけました、

Set Shell = CreateObject("Shell.Application")
Set dOko = Shell.BrowseForFolder(&H0, "フォルダを選んでください", _
&H1 + &H10 + &H40, &H11)

この中の「&H40」がその部分、これでフル・パスでフォルダが取得できます、その値を例えばA1に保存しておき・・・、

f_path = Range("A1").Value
ChDrive "" & Left(f_path, 1) & ""
ChDir f_path

とすれば環境設定で登録した場所をデフォルトとすることが出来ます、ところでこの「&H40」という引数はWindows2000でのみ有効らしいのです。

回答納期のマクロ

あるメーカーでは・・そうあのメーカーです、回答納期が変更になった場合、その内容が私宛にメールが届くようになっています、それをそのまま社員に転送していました。

いくつかのメーカーの納期回答をEDIから引っ張って整形して印刷しそれを毎朝回覧しています、冒頭の回答納期の変更もそのように出来ないかと考えたのが以下のマクロ。

Sub データ整形()

With Application
　　.ScreenUpdating = False

　　ClpBrd.GetFromClipboard'クリップボードからDataObjectにデータを取得する

　　ActiveSheet.PasteSpecial _
　　　　Format:="Unicode テキスト" 'Unicode テキストで貼り付ける

最終行 = Cells(Rows.Count, 1).End(xlUp).Row

　　For n = 最終行 To 1 Step -1 '不要なデータを削除
　　　　If Left(Cells(n, 1), 1) = " " Then
　　　　　　Rows(n).EntireRow.Delete
　　　　ElseIf Left(Cells(n, 1), 1) = "" Then
　　　　　　Rows(n).EntireRow.Delete
　　　　ElseIf Left(Cells(n, 1), 1) = "-" Then
　　　　　　Rows(n).EntireRow.Delete
　　　　ElseIf Left(Cells(n, 1), 1) = "春" Then
　　　　　　Rows(n).EntireRow.Delete
　　　　ElseIf Left(Cells(n, 1), 1) = "注" Then
　　　　　　Rows(n).EntireRow.Delete
　　　　End If
　　Next n


'データを区切る

　　Columns(1).TextToColumns _
　　　　Destination:=Range("A1"), _
　　　　DataType:=xlDelimited, _
　　　　TextQualifier:=xlDoubleQuote, _
　　　　ConsecutiveDelimiter:=True, _
　　　　Space:=True, _
　　　　FieldInfo:= _
　　　　　　Array(Array(1, 1), Array(2, 1), _
　　　　　　Array(3, 1), Array(4, 5), Array(5, 5), _
　　　　　　Array(6, 5), Array(7, 5), Array(8, 1))

　　Rows(1).Insert
　　Cells(1) = "注文ＮＯ"
　　Cells(1, 2) = "品目"
　　Cells(1, 3) = "受注数"
　　Cells(1, 4) = "要求日"
　　Cells(1, 5) = "今回納期"
　　Cells(1, 6) = "前回納期"
　　Cells(1, 7) = "受注日"
　　Cells(1, 8) = "受注番号"

　　With Cells(1).CurrentRegion
　　　　行 = .Rows.Count
　　　　列 = .Columns.Count
　　End With

Set ソート範囲 = Range(Cells(1), Cells(行, 列))

　　ソート範囲.Sort _
　　　　Key1:=Range("A1"), _
　　　　Order1:=xlAscending, _
　　　　Header:=xlGuess, _
　　　　OrderCustom:=1, _
　　　　Orientation:=xlTopToBottom, _
　　　　SortMethod:=xlPinYin

　　For h = 2 To 行 '受注番号に"001"を付加する
　　　　Cells(h, 8) = Cells(h, 8) & "001"
　　Next h

Cells.EntireColumn.AutoFit
Columns("B").ColumnWidth = 30.63
Range("A1:H1").HorizontalAlignment = xlCenter
Columns("D:G").EntireColumn.NumberFormat = "yyyy/mm/dd"
Columns("I").Delete

'-------印刷--------
・・・・
・・・
End Sub

本来これもEDIから引っ張れればすごく楽なのですが発想が硬直しているメーカーだからそれは無理な話。

日付変換マクロ

「やっとできたぞ！その2」で書いたマクロ、かなり遅いので別の案を最近になって考えていました、

はじめに書いたのがこれ、↓

Sub お馬鹿なAS400の日付を直す1()
'1070131 形式の日付データを 2007/01/31 の日付形式に変換する。
　　Dim 日付 As Variant

With Application
.ScreenUpdating = False

　　For Each 日付 In Selection
　　　　If 日付 = "" Then Exit For
　　　　日付.Value = 日付.Value + 19000000
　　　　日付.Value = Left(日付, 4) & "/" _
　　　　　　　　　& Mid(日付, 5, 2) & "/" _
　　　　　　　　　& Right(日付, 2)
　　Next
Selection.Columns.AutoFit
.ScreenUpdating = True
End With
End Sub

次に書いたのがこれ、↓

Sub お馬鹿なAS400の日付を直す2()
'1070131 形式の日付データを 2007/01/31 の日付形式に変換する。
　　Dim 行 As Integer
　　Dim 範囲 As Range
　　Dim 日付 As Variant

With Application
.ScreenUpdating = False

　　行 = Range("A1").CurrentRegion.Rows.Count
　　Set 範囲 = Range(Cells(1, 1), Cells(行, 1))

　　　　For Each 日付 In 範囲
　　　　　　日付.Value = DateSerial(Left(日付, 3) + 1900, _
　　　　　　　Mid(日付, 4, 2), Right(日付, 2))
　　　　Next

　　範囲.Columns.AutoFit
.ScreenUpdating = True
End With
End Sub

そして最近考えたのが次のやつ、

Sub お馬鹿なAS400の日付を直すその3()
'1070131 形式の日付データを 2007/01/31 の日付形式に変換する。
'これが一番早い

　　Dim 日付 As Variant
　　Dim 開始列 As Variant
　　Dim 最終列 As Variant

'画面更新停止

　　For Each 日付 In Selection 　　　'Excelが理解できるように整形
　　　　日付.Value = 日付.Value + 19000000
　　Next
　　With Selection
　　　　開始列 = .Column
　　　　最終列 = .Columns(.Columns.count).Column

　　　　'Excel標準機能の「区切り位置」機能を使う

　　　　For i = 開始列 To 最終列 '複数列処理不可、一列ごとに処理する
　　　　　　Columns(i).TextToColumns _
　　　　　　DataType:=xlDelimited, _
　　　　　　textqualifier:=xlDoubleQuote, _
　　　　　　fieldinfo:=Array(1, 5)
　　　　Next i
　　　　　　.Columns.AutoFit '列幅を最大文字数に合わせる
　　End With
　　.ScreenUpdating = True
End With
End Sub

それを

「Celeron 2.66GHz 512KB RAM」
「Windows2000」
「Excel2000」

という恐ろしく遅い職場のロートル・マシンで上記マクロの処理時間を計ったら・・・、

A列すべてに「1091231」というデータを入力し、「2009/12/31」という日付に変換し終わるまでそれぞれ2回ずつ走らせた結果上から順番に

「27秒」
「18秒」
「12秒」

となりました。

最初のは完全に力業、2番目は日付関数を使ったのでそれより少しスマートで早いですがセルごとの処理なのでまだ遅い、、3番目も「1091231」を「20091231」にするのは同じく力業に頼らざるを得なかったのですがExcel標準機能の「区切り位置」機能を使いました、これは列単位の処理なのでほぼ一瞬で「2009/12/31」に変換できるのです。

だが欠点、というほどのもではないのですが前出の2者はセル単位で処理できますが、つまり飛び飛びに選択した範囲も変換可能ですが後者はあくまでも列単位、複数列も可能ですがその場合、必ず隣接していないと変換してくれません、本来の目的なのでこれで良しとしましょう。

ファイル名に次月を反映するマクロ

「型番から記号を抜くマクロ」で書いたマクロには最後に保存するために「SH01_2009_08.DAT」のように「年月」を反映する部分の記述をしてあります。

Name 読み込みデータ As "SH01_" & Format(Date, "yyyy_mm") & ".DAT"

ところがこの作業は次月の価格表を作るので「SH01_2009_09.DAT」としなければならないことに気が付きました。

そこで

Name 読み込みデータ As "SH01_" & Format(Date, "yyyy") & "_" & Right("0" & Format(Date, "mm") + 1, 2) & ".DAT"

とやると「SH01_2009_09.DAT」になった、12月になれば年も繰り越してくれるかなとPCの日付を2009/12にしてやってみたら「SH01_2009_13.DAT」になっちゃいました。

じゃあ

Name As 読み込みデータ As WorksheetFunction.Date(Year(Now()) , Month(Now()) + 1 , 1)

とエクセルの関数を使ってみたけどエラーになります、そこで

Range("A1").Value= "=Date(Year(Now()) , Month(Now()) , 1)"

と一度セルに記述してそこから「年」と「月」を切り出してみようかと思ったのですがこんな冗長的な方法をとらなくてももっとはるかにスマートな方法があるはずだと思って

Name 読み込みデータ As "SH01_" & Format(DateSerial(Year(Now), Month(Now) + 1, 1), "yyyy_mm") & ".DAT"

DateSerial を使ったらちゃんと「年」を繰り越してくれましたけど実はここに辿りつくまで丸2日も掛かったんです。

型番から記号を抜くマクロ

価格表で商品を検索するとき型番に"-"や"/"の記号やスペースが入っているとそれも入力しなければならないのはかなり鬱陶しいですね、そこで検索用にそれらを端折ったものを別の列に作れば使いやすくなるはず。

すでにそうしているのですが毎月ダウンロードしている商品マスターを実は手作業でやっていました、その作業をするたびに面倒くさいなあと思っていたのですが一度作っておけば他メーカーの商品マスターでも少しの変更で使えるのでと思って作り始めました。

Sub test()
With Application
　　.ScreenUpdating = False

読み込み処理（略）・・・

　　For i = 1 To Cells(1, 4).CurrentRegion.Rows.Count
　　　　n = Cells(i, 4)
　　　　n = Replace(n, " ", "")
　　　　n = Replace(n, "-", "")
　　　　n = Replace(n, "/", "")
　　　　n = Replace(n, "(", "")
　　　　n = Replace(n, ")", "")
　　　　n = Replace(n, ".", "")
　　　　Cells(i, 1) = n
　　Next i
　　.ScreenUpdating = True
End With
End Sub

遅い！実に遅い、Replace関数だとセルをひとつずつ処理するので何万行もあれば遅いのは当たり前ですね、とりあえず11000行のデータを処理するのに約3秒かかりました。

そこでマクロ記録で列を丸ごと選択して置換して吐き出したコードを元に作ったのが次の奴。

Sub test2()
With Application
　　.ScreenUpdating = False

読み込み処理（略）・・・

　　With Columns("A")　　　　　　　'空白と[-],[/],[(],[)],[.]を削除
　　　　.Value = Columns("D").Value　　　　'正式型番をＡ列にコピー
　　　　.Replace what:=" ", replacement:="", lookat:=xlPart, _
　　　　　　searchorder:=xlByRows, MatchCase:=False
　　　　.Replace what:="-", replacement:="", lookat:=xlPart, _
　　　　　　searchorder:=xlByRows, MatchCase:=False
　　　　.Replace what:="/", replacement:="", lookat:=xlPart, _
　　　　　　searchorder:=xlByRows, MatchCase:=False
　　　　.Replace what:="(", replacement:="", lookat:=xlPart, _
　　　　　　searchorder:=xlByRows, MatchCase:=False
　　　　.Replace what:=")", replacement:="", lookat:=xlPart, _
　　　　　　searchorder:=xlByRows, MatchCase:=False
　　　　.Replace what:=".", replacement:="", lookat:=xlPart, _
　　　　　　searchorder:=xlByRows, MatchCase:=False
　　End With
　　.ScreenUpdating = True
End With
End Sub

これだとほぼ1秒ほどで完了します、かなり早くなったのですがなんだかごちゃごちゃして見通しが良くない、もっと見通しよく美しく記述できないかと作ったのが次の奴、変数を配列にしてみました。

Sub test3()
　　Dim moji(5) As String, i As Integer
With Application
　　.ScreenUpdating = False

読み込み処理（略）・・・

　　moji(0) = " "　　　　　　　　　　　　　　'空白を削除
　　moji(1) = "-"　　　　　　　　　　　　　　'[-]を削除
　　moji(2) = "/"　　　　　　　　　　　　　　'[/]を削除
　　moji(3) = "("　　　　　　　　　　　　　　'[(]を削除
　　moji(4) = ")"　　　　　　　　　　　　　　'[)]を削除
　　moji(5) = "."　　　　　　　　　　　　　　'[.]を削除

　　With Columns("A")
　　　　.Value = Columns("D").Value　　　　　'正式型番をＡ列にコピー
　　　　For i = LBound(moji) To UBound(moji)
　　　　　　.Replace what:=moji(i), replacement:=""
　　　　Next i
　　End With
　　.ScreenUpdating = True
End With
End Sub

実行時間は(test2)と変わりません。

ついでにマクロの実行時間を計測するマクロも作りました。

Sub かかった時間()

　　はじめ = Time
　　Call test3
　　おしまい = Time
　　MsgBox (おしまい - はじめ) * 24 * 60 * 60 & "秒"

End Sub

Excelでスタイル

Excelに「スタイル」という機能があります。

いつも読んでいる雑誌に使い方が載っていたので読んでみたら「ふーん、なんか便利そう」というわけで下の画像のようにプル・ダウンから選択できるようにした。



いやー、べんりべんりと終了。

再度Excelを起動しプル・ダウンを手繰ってみると・・おや？設定した書式が見事に消えています。

しばし考えてみると・・、そうですよね当たり前ですよね、メニューは引き継ぐけど書式は引き継ぎませんからね。

やはり今まで通りマクロを割り当てた自前のメニューのみに戻しました。

プリンタを切り替えるマクロ

毎月あるメーカーに実需データを送り、申請書なるものを印刷して送付しているのですが以前はコピーして控を取っておきました。

でもコピーって機械をリースしているのですが 5000枚以上/月 使用した場合、一枚あたり 7.5円 だそうです、それ以下はもっと高いんだろうな、それで印刷するとカラーはトナー換算で約5円、モノクロは約1.5円かかります。

そこですでにスキャナーで読み取ってあった会社の角印を申請書に貼り付けカラーとモノクロで印刷分けし、一方を原本、一方を控にするということを目論み作ったのが以下のマクロ。

Sub 印刷()
　　Dim 印刷範囲 As Range
　　Dim prSet(2) As String

　　Set 印刷範囲 = Range("A3:P44")
　　prSet(1) = "EPSON LP-9200C on Ne04:"
　　prSet(2) = "EPSON LP-9300 on Ne02:"

　　For nh = 1 To UBound(prSet)
　　　　印刷範囲.PrintOut _
　　　　　　copies:=1, _
　　　　　　ActivePrinter:=prSet(nh), _
　　　　　　collate:=True
　　Next nh
End Sub

これで先月はちゃんと動いたので今月もと走らせたら2枚ともモノクロで出てしまいました、そこでマクロの自動記録で調べたらポート番号が"Ne05:"になっていたので prSet(1)の部分を"Ne05:"に替えましたがやはりモノクロで2枚とも出ちゃうのです。

いろいろ調べたらどうやら基本的にはじめに空いているポートを使っちゃうらしいのです、詳しいことは良く分からないですが多分デフォルトのプリンターに戻していないのでだめなんじゃないかと思って以下のマクロのように戻すようにしたら今のところちゃんと動いているようです、来月再確認しよう。

Sub 印刷()
　　Dim 印刷範囲 As Range
　　Dim prSet(2) As String

　　With Application
　　　　Set 印刷範囲 = Range("A3:P44")
　　　　普段使っているプリンタ = .ActivePrinter
　　　　prSet(1) = "EPSON LP-9200C on Ne03:"
　　　　prSet(2) = 普段使っているプリンタ

　　　　For nh = 1 To UBound(prSet)
　　　　　　 印刷範囲.PrintOut _
　　　　　　　　　　copies:=1, _
　　　　　　　　　　ActivePrinter:=prSet(nh), _
　　　　　　　　　　collate:=True
　　　　Next nh
　　　　.ActivePrinter = 普段使っているプリンタ
　　End With
End Sub