配列再び。
Excelシートを配列を用いてデータ処理をする時期をすごしています。
一時ワークシートを作っていろいろするより早さもそうですが，コードもシンプルになっていい。
ただ，一時ワークシートの利点と思っているのが，セルの番地等が一目瞭然である点です。
一時ワークシートを作成し，データ処理をしているところでコードを止めてあげると情報を一望でき，メンテナンスは比較的簡単。
配列は・・・ローカルウィンドウでちくちく見てますが，データ構造がずれたりするとほんと大変ですよね。。
本職でコーディングするわけではないので，仕様はころころ変わりますし，その仕事の大前提がひっくり変えることも多々ありますから，そういう時にこまったことになります。
やはり同じ流れでクラスモジュールに気持ちが向かっていくんだなぁと，苦笑しつつ去年のコードを見返しています。
thomさんからいろいろアドバイスをいただいて，去年は大量のデータを扱うことをしていました。
今年は去年ほどの項目数がないので，配列でちゃちゃっとすませてしまったんですが，それでも６０程度の項目はあるのかな，メンテナンスのことを考えると，ちょっと途方にくれます。
自分なら自分のメンテナンスは癖がわかってますからやりやすいですが，他人のコードはどこになにがあるのかがわからないと困ります。
特に配列ですから数値指定のものが多く，とても困る。
リハビリ兼ねてすこしずつクラスモジュールを思い出すことにしました。
標準モジュール
Option Explicit Function GetDataAsArray() As Variant GetDataAsArray = Sheets(1).Range("a1").CurrentRegion.value End Function Function GetDataAsCollection() As Collection Dim arr: arr = GetDataAsArray Dim C As Collection: Set C = New Collection Dim i, j For i = LBound(arr, 1) + 1 To UBound(arr, 1) With New Person If C.Count = 0 Then .AdjustArrSize UBound(arr, 2) For j = 1 To UBound(arr, 2) .LetParameter j, arr(i, j) Next C.Add .Self End With Next Set GetDataAsCollection = C End Function Sub テスト() Dim a As Collection: Set a = GetDataAsCollection Stop End Sub
クラスモジュール クラス名 Person
Option Explicit Private Parameter() As Variant Property Get 名前() As String 名前 = Parameter(1) End Property Property Get Self() As Object Set Self = Me End Property Sub LetParameter(paramNo, value) If Not Not Parameter Then Else Call AdjustArrSize(100) Parameter(paramNo) = value End Sub Function GetParameter(paramNo) As Variant GetParameter = Parameter(paramNo) End Function Sub AdjustArrSize(No As Long) ReDim Preserve Parameter(1 To No) End Sub
昨年度教えてもらったやり方から，現時点ではほぼ変わっていません。
ただ，当時項目数が増えたときにその上限を書き換えにいく必要があり，それがちょっと面倒だなぁと思っていました。
大きめに項目数を見て作ればいい話ですが，Emptyが並んでいると，あまり広くないローカルウィンドウがとても狭く感じるのでデータ項目数に合わせて可変にしたいと思っていました。
その部分をとりあえず付け足して書いてみた。
AdjustArrSizeというのを付け足してRedimしているだけですけどね・・(;´▽｀A``
ただし，忘れる前提で話をしているので，それを忘れて実行したときは100項目というかなり大きめの項目数で動きはするように作ってみた。
If Not Not Parameter Then Else Call AdjustArrSize(100)
Not Not ってのがわかっていませんが，いろいろネットを見てたら出てきたので Redimし忘れ対策です。
結果は
とりあえず私が望むデータの項目数に応じた構成データ数というのは実現できているようです。スマートな書き方ではないとは思いますが，見た目はとりあえず成った。
そしてクラスモジュールならプロパティ実装部分に重要な項目を集めておけばコードがだいぶ見やすくなると思います。
とても大事な部分ですが，
With New Person
If C.Count = 0 Then .AdjustArrSize UBound(arr, 2)
For j = 1 To UBound(arr, 2)
.LetParameter j, arr(i, j)
Next
C.Add .Self
End With
この部分がどうも理解できていません。
やってることはわかるけどどうしてこう書けるんだ??
記録マクロとかでもよくWithでさくっと書かれているときに戸惑うことはあります。苦手な部分なんでしょうね。
いろいろ試して物にしていこう。
Worksheetのコピー
前回書いてみた通り，
Sub a() 'だめ Dim PWB As Workbook: Set PWB = Workbooks.Add() Dim PWS As Worksheets: Set PWS = ThisWorkbook.Worksheets(1).Copy(after:=PWB.Worksheets(PWB.Worksheets.Count)) End Sub Sub b() 'うまくいく Dim PWB As Workbook: Set PWB = Workbooks.Add() Dim PWS As Worksheet: ThisWorkbook.Worksheets(1).Copy after:=PWB.Worksheets(PWB.Worksheets.Count) Set PWS = ActiveSheet End Sub
PWSという変数に，シートのコピーを一気に入れたい。
たった一行の差なんですが，コピー直後は必ずコピーしたばかりのシートがアクティブになってるからという前提で書くbの書き方が嫌いです。
オブジェクトブラウザでみても
Sub Copy([Before], [After])
Excel.Worksheets のメンバー
と書いてあるから，ワークシートを返すのかなぁと思うので直接入れれそうに感じるんですがだめなようです。
何が悪いのかなぁ ( ´ー｀)ﾌｩｰ．．．
・・・
ここまで書いてて，もう一回オブジェクトブラウザ見て思った。
Addは
Function Add([Before], [After], [Count], [Type]) As Object
Excel.Worksheets のメンバー
Copyは
Sub Copy([Before], [After])
Excel.Worksheets のメンバー
Functionじゃないから返さないよね・・・(ノД`)・゜・。
書き方の問題じゃないなぁ( ´ー｀)
ExcelVBA VBAでワークシートをコピーした時印刷レイアウトが思うとおりにならない件の対処
仕事上ちょっと困ってて，対処ができたので備忘録としてメモ
印刷レイアウトをこまかくきちんと設定したシートを新しいブックにコピペしてるのに，印刷範囲からはみ出してしまうという現象にわたしは数度遭遇しています。
VBAじゃなくて手動でするときはそうならないこともあるんですが，VBAでやると大幅にはみだしたりしてる。
列幅やページ設定等が変わったのなら，まだ対処は考えやすいんですが，そのへんはきちんと保持されているんです。
なので，どうしたらいいのか途方にくれていたり放置していたんですが，放置するわけにはいかない仕事がありまして，
その対処をまじめに調べたりしてたら対処できました。
原因は，一言でいうとスタイル設定が一致していないせいみたいです。
なので，VBAを使わないひとであれば，元にしたいワークブックと，スタイル設定が崩れてしまったワークブックを開いた状態で
崩れた方から
ホーム → スタイル →(スタイル一覧の下の方の)スタイルの結合
としてあげると，たぶん想定通りの印刷範囲が実現されます。
で，これをVBAで対処したのが
Sub a() Dim PWB As Workbook: Set PWB = Workbooks.Add Application.DisplayAlerts = False PWB.Styles.Merge Workbook:=ThisWorkbook Application.DisplayAlerts = True ThisWorkbook.Worksheets("テスト").Copy after:=PWB.Worksheets(PWB.Worksheets.Count) Dim PSht As Worksheet: Set PSht = ActiveSheet End Sub
時間があまりないので説明がほとんどないのはすみません。
PWBってのに新しくワークブックつくって放り込んで，そこにマクロが書かれたブックからシートをコピペしているだけです。
作られたブックには，きちんとスタイルの結合をしているので，たぶんレイアウトは崩れない。
DisplayAlertsを設定しているのは 結合していいかっていうダイアログがうざいからです。
メモおわり。。
ところで，
ThisWorkbook.Worksheets("テスト").Copy after:=PWB.Worksheets(PWB.Worksheets.Count)
Dim PSht As Worksheet: Set PSht = ActiveSheet
この部分を一文で表したいんですが，どこかが悪いらしく私が書くとエラーになってしまいます。
スマートな書き方ありませんか・・(´；ω；`)
配列扱いメモ
とても久しぶりに書くことになります。vbaはたまーに組んでますが，今年はそれ以外の仕事が多くて去年のようにはいきません。
いろいろ，すっかり忘れてしまいました。ただ，時期的にExcelで配列を扱わないといけないので，いろいろ組んでいたら，結局自分がいろいろと書き残したこのページを久しぶりに見にきました。
でも，去年がんばった分，excelの処理であっても一時シート作ってそこでごちゃごちゃやって，貼り付けた後一時シートを消す，という風には頭が動かない。
配列でちゃちゃっとやりたいな，と思うところは以前とはかわったようです。
ただ，VBAの知識がある人がまったく職場にいない可能性が今あるので，引き継ぐときは，一時シート上で処理をする方法も書きたいところではありますね。。
さて，久しぶりに自分のページを見に来た理由は，他の方のページを参考にバブルソートで降順並べ替えにすると，またしても安定ソートなのに同じキーに対してデータが入れ替わってしまったため。
前悩んだよなぁと思い，見に来ました。
まだコレクションとか思い出せないので使えませんが，以前よりかなりデータ量は少ない状態で今回はやれるので，配列のみでやってしまうことにしています。
自分用コードなので，間違いなどあっても保証はできません。悪しからず。
元データを仮に次のように用意
コードは今のところここまで
Option Explicit Sub メイン処理仮() Dim SSht As Worksheet: Set SSht = ThisWorkbook.Worksheets("Sheet1") Dim データ() As Variant Dim 最下行 As Long: 最下行 = SSht.Cells(Rows.Count, 1).End(xlUp).Row Dim 項目数 As Long: 項目数 = SSht.Cells(1, Columns.Count).End(xlToLeft).Column ReDim データ(1 To 最下行, 1 To 項目数) データ = SSht.Range(SSht.Cells(1, 1), SSht.Cells(最下行, 項目数)).Value Dim i As Long, j As Long, 抽出数 As Long Dim 抽出 As Variant 抽出 = レコード抽出(データ, 2, "C") Dim 抽出2 As Variant 抽出2 = 不要列削除(抽出, "5,6,7") '削除列の順番は必ず小さい順に書くこと。 Dim 抽出3 As Variant 抽出3 = ソート(抽出2, 4, True) Dim 抽出4 As Variant 抽出4 = ソート(抽出2, 4, False) Call 一時シート作成 Dim TSht As Worksheet: Set TSht = ThisWorkbook.Worksheets("一時") Call シートへ転記(抽出, TSht.Range("a1")) Call シートへ転記(抽出2, TSht.Range("a10")) Call シートへ転記(抽出3, TSht.Range("a20")) Call シートへ転記(抽出4, TSht.Range("a30")) End Sub Function レコード抽出(ByVal 配列 As Variant, 項目列 As Long, 抽出値 As String) As Variant Dim 項目数 As Long, データ数 As Long データ数 = UBound(配列, 1) 項目数 = UBound(配列, 2) Dim 一時配列() As Variant Dim i As Long: i = 1 Dim j As Long Dim 抽出数 As Long: 抽出数 = 1 ReDim 一時配列(1 To 300, 1 To 項目数) Do If 配列(i, 項目列) = 抽出値 Then For j = 1 To 項目数 一時配列(抽出数, j) = 配列(i, j) Next 抽出数 = 抽出数 + 1 End If i = i + 1 Loop Until i = データ数 + 1 抽出数 = 抽出数 - 1 '１多くなってループを抜けるので Dim 一時配列2() As Variant 一時配列2 = WorksheetFunction.Transpose(一時配列) ReDim Preserve 一時配列2(1 To 項目数, 1 To 抽出数) レコード抽出 = WorksheetFunction.Transpose(一時配列2) End Function Function 不要列削除(ByVal 配列 As Variant, 不要列 As String) Dim 一時配列() As Variant ReDim 一時配列(1 To UBound(配列, 1), 1 To UBound(配列, 2)) Dim i As Long: i = 1 Dim j As Long Dim k As Long Dim flg As Boolean Dim 削除列数 As Long: 削除列数 = UBound(Split(不要列, ",")) + 1 For k = 削除列数 - 1 To 0 Step -1 For i = 1 To UBound(配列, 1) flg = False For j = 1 To UBound(配列, 2) If j = Split(不要列, ",")(k) Then flg = True Else If flg = False Then 一時配列(i, j) = 配列(i, j) Else 一時配列(i, j - 1) = 配列(i, j) End If Next Next 配列 = 一時配列 Next ReDim Preserve 配列(1 To UBound(配列, 1), 1 To UBound(配列, 2) - 削除列数) 不要列削除 = 配列 End Function Function ソート(ByVal 配列 As Variant, ソート列番号 As Long, 昇順 As Boolean) Dim 入替用 As Variant Dim i As Long, j As Long, k As Long Dim flg As Boolean For i = LBound(配列, 1) To UBound(配列, 1) - 1 For j = LBound(配列, 1) To UBound(配列, 1) - i If 昇順 Then If 配列(j, ソート列番号) > 配列(j + 1, ソート列番号) Then flg = True Else flg = False Else If 配列(j, ソート列番号) < 配列(j + 1, ソート列番号) Then flg = True Else flg = False End If If flg Then For k = LBound(配列, 2) To UBound(配列, 2) 入替用 = 配列(j, k) 配列(j, k) = 配列(j + 1, k) 配列(j + 1, k) = 入替用 Next End If Next Next ソート = 配列 End Function Sub シートへ転記(ByVal 配列 As Variant, セル As Range) セル.Resize(UBound(配列, 1), UBound(配列, 2)).Value = 配列 End Sub Sub 一時シート作成() Application.DisplayAlerts = False On Error Resume Next ThisWorkbook.Worksheets("一時").Delete On Error GoTo 0 ThisWorkbook.Worksheets.Add after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count) ActiveSheet.Name = "一時" Application.DisplayAlerts = True End Sub
自分用なので結果のSSは載せません。
ただ，少ないデータでやった感じでは，抽出，列削除，ソート等なんとなくうまくいってる風です。
とりあえず汎用のパーツだけ作ったけど 抽出，ソート，シートへ貼ることさえできれば普段やる仕事は全部できるから，けっこう用意できた気がします。
明日職場で去年のデータひっぱりだしてこのコード使ってみて，想定通り動くか試してみよう。
うまくいくかなぁ。
・・・ドメイン解除したりしたため，リンクとか切れまくりですが，いつか暇があればきちんとしようかな。。 わかりませんけど・・。
近況です
ずいぶんと書けていませんが，googleにきちんと登録されているようで，アクセス数はけっこうあるようです。
PROにして独自ドメインにした効果なんでしょうね。
現在はずいぶんとネタが無いので書けません & とてもとても久しぶりにFF14に手をだしてしまいました。
今日はメンテナンス中のようですので，生存報告だけ書こうと思い，書いています。
Powerpoint VBAネタをやめるつもりはないのですが，FF14を始めたとはいえ，朝も早く，帰りも遅い生活は続いていますし，その中VBAの取り組みは，
今年転勤した職場の既存のシステムのうち我慢ならない部分から手をいれるという程度しか取り組む時間はありません。
仕事が減らない。。
夏休みか，その直前になるくらいまでは，ちょっと新しいものを作って記事にするのは難しそうです。。
夏休みは・・教材作成がてら何かやれたらなぁと思いますし，忘れるのがとても早い私ですから，VBAを思い出しながらそれを記事にしていくのかもしれません。
幸いなことはあります。
これは本当に作ってよかったと思います。
今年は化学基礎と科学と人間生活を教えているのですが，両方とも原子の分野があり，原子核とその周りを回っている電子というところで，今までは動かない絵を黒板に書いたり，電子黒板に表示するにとどまっていたのですが，動きますし，原子番号が増えると，陽子や電子が増えていく。電子がある程度を超えると，次の電子殻が増えてそこに入っていくよ・・という話がしやすくなりました。
Powerpoint2010ではちょっと変な動きをして，ボタンを押したらくるくる回って応答なしになるので，タブレットのPowerpoint2013で動かさないといけないのは，たまに傷なのですが，まぁそれでも十分解説はできています。
作った瞬間からお気に入りでしたが，実際使ってしゃべってみてもやはりお気に入りです。
物質量molの話は表計算で考えるといいよ，と 最近ある研修で学びました。
その話にはとてもうなずけます。
その辺は作りたいんですよね。。
あとは化学反応式ネタもきちんとやりたい。
物理ネタは教えていないのですることがちょっとなくなりましたが，
化学のネタについてはやることはありますので，夏休みが近づいたら少しは書き始めようと思っています。
それまではもうしばらく放置が続きますが，googleさんのおかげで，初めてここをおとずれている方もいらっしゃるようです。
しばらくは今まで書いた分で放置が続きます。。
ファイル一覧続き テキストファイルに書き出してみました。
OfficeアプリをVBAで扱っているときは，それらが高機能であるために，あまり縛られることはないですが，
テキストに助けを求めると，いろいろと怒られるものですね。
前回のファイル一覧をテキストファイルに書き出そうとしたら，環境依存文字で怒られました。
Option Explicit call getallfilename Sub getAllFilename() Dim objFS 'As Object Set objFS = CreateObject("Scripting.FileSystemObject") Dim objWshShell ' As Object Set objWshShell = CreateObject("Wscript.Shell") Dim objFolder ' As Object Set objFolder = objFS.GetFolder(objWshShell.CurrentDirectory) Dim objFile ' As Object Dim strFileName ' As String Dim objText 'As Object Set objText = objFS.createtextfile(objFolder & "\new.txt", True, True) For Each objFile In objFolder.Files objText.writeline (objFile.Name) Next objText.Close End Sub
テキストファイルの扱いは以前から毛嫌いしているので，書けたからいいや的なコードです。
以前のコードからの変更点は
ファイルシステムオブジェクトのCreateTextFileメソッドでテキストファイルを作成します。
Set objText = objFS.createtextfile(objFolder & "\new.txt", True, True)
この部分です。
一つ目の引数は上書きオプションらしいです。今は常に上書きするように書いています。
二つ目の引数が環境依存文字にとっては大事な点になりますが，unicodeオプションみたい。
環境依存文字も使えるから普通に使ってファイル名を決めてしまっているので，ここをtrueにすることで，環境依存文字でも怒られずにテキストファイルにファイル名を書き出せました。
前のテキストに書き足すとかの処理を考えないなら，writelineは勝手に改行してくれるのでとても楽ですね。
ファイル名一覧とかめんどくさいので，いつもは SnippingToolでそのフォルダのSSを取ってWord等に貼っていましたが，
このスクリプトを同じフォルダに入れて実行するだけで一覧を作らせることができます。
望んだ機能拡張を気軽にできるし，excelやword等，立ち上げて終了させて，に少し時間がかかるのでこんな作業ならさくっとテキストに書き出させるのはいい。
FileSystemObjectってすごいんだなぁと感心する今日この頃です。
食わず嫌いはだめですね。CreateObjectで使うものにきちんと取り組んでいかないと。。
objText.Close
これって書かなくても怒られないんですが，必要なのかなぁ。
書かなくてもすみそうなものは，一行でも削ろうとしてしまうので，動くからいいじゃない派としては気になるところでした。
－－－
そういえばなんでVBAでどうのこうのにこだわっていたのに，飛び出してVBScriptなんだろうと自分で振り返るんですが，
今ExcelにしろPowerpointにしろ立ち上がるのがもっさりしているんですよね。
Excelは特に，職場とかだと開いてからセルに文字が入力できるようになるまでがとても長い。
ただ情報を知りたいというだけならテキストに書き出してメモ帳でさくっと開いて何にでも使えるよ，が楽な時によく出くわします。
なのでケースによってはword,powerpoint,excelを開かずに用を済ませたい。
次々に，適切なファイル名のテキストに自分好みの分類で出力していってさくさく作業したいとか，
そのテキストファイルを今度こそVBAで開いて操作したいとか
はたまた，正規表現オブジェクトとそれらテキストで最後までやってしまうとか，使えるツールが増えるとよりスマートにできそうですよね。。
いろいろできるようになりたいなぁ。
