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を思い出しながらそれを記事にしていくのかもしれません。

幸いなことはあります。

blog.powerpointvba.club

これは本当に作ってよかったと思います。

今年は化学基礎と科学と人間生活を教えているのですが，両方とも原子の分野があり，原子核とその周りを回っている電子というところで，今までは動かない絵を黒板に書いたり，電子黒板に表示するにとどまっていたのですが，動きますし，原子番号が増えると，陽子や電子が増えていく。電子がある程度を超えると，次の電子殻が増えてそこに入っていくよ・・という話がしやすくなりました。

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で開いて操作したいとか

はたまた，正規表現オブジェクトとそれらテキストで最後までやってしまうとか，使えるツールが増えるとよりスマートにできそうですよね。。

いろいろできるようになりたいなぁ。

VBScript ファイル一覧続き

VBScriptのエディタとしてVBAでいつも使っているVBEditorがいいという話をthomさん達から聞きましたので，

早速職場でも試してみました。

使い慣れた部分のおかげや，参照設定無でも十分コーディングの手助けをしてくれますし，

ローカルウィンドウがやっぱりいい。

SpecialFolderとしてどんなものがあるか，とかプロパティをいろいろ見れるところとか　とってもいいですね。

VBEditorにミスの指摘とかをずいぶんしてもらえるので，普通のテキストエディタで打つだけで精一杯の時より，ずいぶん余裕が出てきます。

あと，モジュールが使えることもとてもありがたいですし，

前回とほぼ同じですが，無駄とかあったので書き直してみました。

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
    
    For Each objFile In objFolder.Files
        strFileName = strFileName & objFile.Name & vbCr
    Next
    
    MsgBox strFileName

End Sub

msgbox "Test"

これを実行すると，callに従い，一度サブルーチンを実行した後，サブルーチンの部分は飛ばして下のメッセージボックスを実行する。

全く知識が無いので，

「へ～　そう動くんだなぁ」

と面白がれます。

いろいろと制限多いらしいですし，Like演算子が使えないのは，その便利さを最近実感していたところなので残念ですが，

十分高機能とも思える。

VBAとも連携できるのでしょうし，使い方だろうと思えます。

もうちょい遊んでいられそう。

VBScript ファイル一覧を取得

あるフォルダに入っているデータすべてに対して調査をしたい。

こんな処理をするのが私は好きなんですが，VBScriptでできるのかなぁというのを試してみました。

このコードを保存した場所のファイル一覧をMsgBoxに吐き出すスクリプトです。

set objFS=CreateObject("Scripting.FileSystemObject")

dim objWshShell
set objWshShell=WScript.CreateObject("WScript.Shell")
set objFolder=objFS.GetFolder(objWshShell.CurrentDirectory)

for each objFile in objFolder.Files
	strFileName=strFileName & objFile.Name & vbCr
Next

msgbox strFileName

大文字小文字がしっかりしていないのは許してください。適当です。

普通のエディタでコード打ってます。

いとも簡単にできるものなんですね。

しかも私が大好きなFor eachでできるのはとてもいい。Dir関数でやるの苦手なんです。

これって同じ風にExcelやPowerpointのVBAでもできるのかな。

できると，楽だなぁ。

このコードはほとんどは本を見ながら打ったものです。

VBScriptの本　買いました。

[改訂版] VBScriptポケットリファレンス (POCKET REFERENCE)

目からうろこが落ちる感じ。

数ページ進んだらもう　クラスのことが書いてあります。

ExcelやPowerpointのように，元々が高性能な基盤があり，それを補助するならクラス無くてもやっていけることも多々あるんでしょうけど，

土台があんまりない場合はクラスは避けて通れないのかなぁと漠然と思ったり。

いろんな勉強になりそうです。

他言語はちょっと覚える気にはならないんですが，VBAの親戚あたりならやる気になる。

VBScript逆引き大全500の極意

こちらの本も買いました。二冊で十分勉強になりそう。

こちらの本は井川はるきさん

今となっては極めて高いあのExcelVBA本を書いた方が携わられた本なのかな。

勉強にもってこいです。

あと，CreateObjectが苦手な私にはその辺の克服のためにもVBScriptはいい気がします。

暇をみつけてちょこちょこやっていこう。

VBScript を少しずつ

VBScript でちょこっとコードをメモ帳で書いて，職場で試してみると動きました。

ってことは使えるって思っていいよなぁと思い，少しずつ書いてみることに。

ちゃんとやったことはないので，VBAとの違いを楽しみながら遊んでみようと思います。

デスクトップにあるBook1.xlsmってファイルを開いてみる。

option explicit

dim xlapp
Set xlapp=CreateObject("Excel.Application")

xlapp.Application.visible=true

Dim WS, SP 
Set WS = CreateObject("WScript.Shell") 
SP = WS.SpecialFolders("desktop") 

dim WB
xlapp.workbooks.open sp & "\Book1.xlsm"
set WB=xlapp.workbooks(1)

WB.worksheets(1).cells(1,1).value="TEST"

上のコードをメモ帳にでも貼って，拡張子vbsのファイルを作ればコードは完成です。 test.vbsみたいな感じ。

activeworkbook.path の類が使えないんですね・・。

でもネットでちょっと探したらすぐSpecialFoldersの使い方が出てきました。やっぱりネットはアリガタイ。

Illustratorでもコードが使えればという気持ちも持ちつつ，コードの土台としてExcelかWordかPowerpointを選ばなきゃいけないことに抵抗がある時もありましたので，

学びたいですね。

VBScriptのいい本ってどれだろうなぁ。

WSHで調べないといけないのかな??

その辺からよくわかっていませんが，ちょっと楽しそうだなぁと思っているところです。

Powerpointとかも外部から操作して遊べるのかな。。そのあたりができ始めれば，ブログ名詐欺じゃなくなってくる・・かな(;´･ω･)

調べてみたら，どんどん出てきますね。

コードを保存している場所?をメッセージボックスで出力

option explicit
dim objWshShell

set objWshShell=WScript.CreateObject("WScript.Shell")

msgbox objWshShell.CurrentDirectory

パワーポイントも開いてみた

dim pptapp
set pptapp=createobject("powerpoint.application")

pptapp.visible=true

dim PS
pptapp.presentations.open sp & "\3択基本①.pptm"
set PS=pptapp.presentations(1)

小文字で書いても動くかやってみたら動いた。

vbaな気持ちで書いていくといろいろできそうだ。

夢が広がる。