![[PukiWiki]](image/pukiwiki.png "[PukiWiki]")
#author("2023-02-10T14:55:18+09:00","default:irrp","irrp") #author("2023-02-22T22:08:50+09:00","default:irrp","irrp") →Office関連メモ →Excel関連 →C＃によるExcel制御 →Visual Basic(.NET以前) #contents * サブトピック [#zd8f2c00] -ExcelのVBAで図形／シェイプの処理 *一般 [#bbc20b28] -[[XML 要素を XML マップのセルに対応付ける - Microsoft サポート>https://support.microsoft.com/ja-jp/office/xml-%E8%A6%81%E7%B4%A0%E3%82%92-xml-%E3%83%9E%E3%83%83%E3%83%97%E3%81%AE%E3%82%BB%E3%83%AB%E3%81%AB%E5%AF%BE%E5%BF%9C%E4%BB%98%E3%81%91%E3%82%8B-ddb23edf-f5c5-4fbf-b736-b3bf977a0c53#__create_an_xml]] 2023.2 -[[【VSCode】XVBAを使ってExcel VBA開発 | とあるエンジニアの備忘録>https://rent-web.jp/post-89/]] 2022 -[[Excel VBAでもう頑張らない | フューチャー技術ブログ>https://future-architect.github.io/articles/20230209a/]] 2023.2 -VarTypeで8204などが返ってくるとき -- 配列を指定した場合は、配列(8192)+型番号の値が返ります。8204ならVariant(12)の配列 --http://www.openreference.org/articles/view/460 -[[VBAの「ソースコードをロック」ではソースコードをロックできない - Qiita>https://qiita.com/kn1cht/items/e97f00fdcf2e7d456cfa]] 2022.7 -[[VBA100本ノック：マクロVBAの特訓｜エクセルの神髄>https://excel-ubara.com/vba100/]] 2021.3 -[[エクセルアドインとは>http://hp.vector.co.jp/authors/VA029807/jim_carry-xla-exp.htm]] -[[エクセルＶＢＡ・マクロ勉強参考サイトまとめ>http://matome.naver.jp/odai/2132773983649074301]] -[[コントロールの誤操作でマクロが作成される>http://pc.nikkeibp.co.jp/article/column/20091109/1020285/?P=1]] -[[VB & VBAプログラミング>http://www.ops.dti.ne.jp/~allergy/vb/vbvba.html]] -[[すぐに役立つVBAマクロ集>http://www.happy500z.com/]] --[[印刷（基本型）>http://www.geocities.jp/happy_ngi/YNxv211.html]] -[[ExcelRelaxTools Addin>http://software.opensquare.net/relaxtools/]] 2014.1.29 --5年間(2009年〜)にわたって作成したマクロを汎用的、体系的にまとめたものです。 *Tips [#z68b5d4d] ** 添付ファイルをつけてメール [#p7c0a085] -[[EXCEL VBAでメール一括配信！添付ファイルも付けられるよ その２ - あきらちんの技術メモ>https://www.akiratin.com/excel-vba%E3%81%A7%E3%83%A1%E3%83%BC%E3%83%AB%E4%B8%80%E6%8B%AC%E9%85%8D%E4%BF%A1%EF%BC%81%E6%B7%BB%E4%BB%98%E3%83%95%E3%82%A1%E3%82%A4%E3%83%AB%E3%82%82%E4%BB%98%E3%81%91%E3%82%89%E3%82%8C%E3%82%8B/]] 2020 ** 画面をキャプチャする [#d6d9263d] -[[Excel VBA を学ぶなら moug モーグ | 即効テクニック | 画面をキャプチャする>https://www.moug.net/tech/exvba/0150121.html]] 2015 ** Googleマップ表示 [#z16f89c2] -[[ゼロからはじめるExcel VBA＋Webサービス(9) Googleマップを表示してみよう【Google Maps Platform?】 | TECH+>https://news.mynavi.jp/techplus/article/excelvbaweb-9/]] ** CSVやExcelにSQLを実行 [#ud98d858] -[[【Excel VBA】CSVやExcelファイルにSQLを実行するツール - Qiita>https://qiita.com/taukuma/items/7c65f377e62081800804]] ** マクロの自動実行を抑制 [#e8efef0f] -[[マクロを実行させずにExcelファイルを開く方法。ブックオープン時に自動的にマクロが実行されなくなるよ | ラブグアバ>https://love-guava.com/open-excel-book-without-running-macro/]] 2019 --ファイルを開く→Shiftを押しながら開く -[[［Excel VBA］マクロの自動実行を止めるには？ | 日経クロステック（xTECH）>https://xtech.nikkei.com/it/atcl/column/15/090100207/090100052/]] 2015 Application.EnableEvents = False ** 警告抑制 [#c478d36c] Application.DisplayAlerts = False '警告抑制 ** ファイルダイアログ（オープン） [#f5041b4a] Dim dlg As FileDialog Set dlg = Application.FileDialog(msoFileDialogOpen) dlg.InitialFileName = "C:\Windows\" dlg.Show 'execute だと開く所までやってくれる Cells(1, 1) = dlg.SelectedItems(1) -[[[VBA]フォルダ選択ダイアログの使い方・使い分け>https://y-moride.com/vba/dailog-folder-picker.html]] 2021 -Win32APIを直叩きしたい場合 --https://www.moug.net/tech/acvba/0020007.html Public Declare Function GetOpenFileName _ Lib "comdlg32.dll" _ Alias "GetOpenFileNameA" ( _ pOpenFileName As OPENFILENAME) As Long 'pOpenFileName構造体(ユーザー定義型)の宣言 Type OPENFILENAME lStructSize As Long '構造体のサイズ hwndOwner As Long 'ダイアログを所有 ' するウインドウハンドル hInstance As Long 'アプリケーションインスタンス lpstrFilter As String 'フィルタ lpstrCustomFilter As Long 'ユーザ定義フィルタ nMaxCustrFilter As Long 'ユーザ定義フィルタの ' バッファサイズ nFilterIndex As Long 'デフォルトフィルタのインデックス lpstrFile As String '選択されたファイル名 nMaxFile As Long 'ファイル名のバッファ lpstrFileTitle As String '選択されたファイル名のタイトル nMaxFileTitle As Long 'ファイル名のタイトルのバッファ lpstrInitialDir As String '初期ディレクトリ lpstrTitle As String 'ダイアログボックスのタイトル Flags As Long 'オプション nFileOffset As Integer 'ファイル名の最後の「\」までの ' オフセット値 nFileExtension As Integer '拡張子までのオフセット値 lpstrDefExt As String 'デフォルトの拡張子 lCustrData As Long 'OSがフック関数に渡すアプリ定義のデータ lpfnHook As Long 'メッセージを処理するフック関数 ' へのポインタ lpTemplateName As Long End Type '定数宣言 '複数のファイルを選択可能に Public Const OFN_ALLOWMULTISELECT = &H200 'ファイルが存在しなかった場合、新規作成するかどうか表示 Public Const OFN_CREATEPROMPT = &H2000 'エクスプローラ形式のダイアログを使用 Public Const OFN_EXPLORER = &H80000 '存在しないファイル名を入力不可に Public Const OFN_FILEMUSTEXIST = &H1000 '「読み取り専用」チェックボックスを非表示 Public Const OFN_HIDEREADONLY = &H4 'カレントディレクトリをダイアログのカレントディレクトリにする Public Const OFN_NOCHANGEDIR = &H8 Public Const OFN_NODEREFERENCELINKS = &H100000 'ネットワークコンピュータを非表示に Public Const OFN_NONETWORKBUTTON = &H20000 Public Const OFN_NOREADONLYRETURN = &H8000 Public Const OFN_NOVALIDATE = &H100 'ファイルが存在していた場合、上書きを問い合わせる Public Const OFN_OVERWRITEPROMPT = &H2 '有効なパス名のみを入力可能に Public Const OFN_PATHMUSTEXIST = &H800 '「読み取り専用」チェックボックスをオンにする Public Const OFN_READONLY = &H1 '「ヘルプ」ボタンの表示 Public Const OFN_SHOWHELP = &H10 '拡張子がデフォルトの拡張子と異なる場合に設定されるフラグ Public Const OFN_EXTENSIONDIFFERENT = &H400 Public Function GetFileName() As String Dim pOpenFileName As OPENFILENAME Dim lngRet As Long 'Accessアプリケーションのハンドルを取得 pOpenFileName.hwndOwner = Application.hWndAccessApp pOpenFileName.hInstance = 0 'ファイルフィルタの設定 pOpenFileName.lpstrFilter = "全てのファイル (*.*)" & _ String(1, vbNullChar) & _ "*.*" & _ String(2, vbNullChar) pOpenFileName.lpstrCustomFilter = 0 pOpenFileName.nMaxCustrFilter = 0 pOpenFileName.nFilterIndex = 1 pOpenFileName.lpstrFile = String(511, vbNullChar) pOpenFileName.nMaxFile = 511 pOpenFileName.lpstrFileTitle = String(512, vbNullChar) pOpenFileName.nMaxFileTitle = 511 pOpenFileName.lpstrInitialDir = String(1, vbNullChar) pOpenFileName.lpstrTitle = String(1, vbNullChar) pOpenFileName.nFileOffset = 0 pOpenFileName.nFileExtension = 0 pOpenFileName.lpstrDefExt = String(1, vbNullChar) pOpenFileName.lCustrData = 0 pOpenFileName.lpfnHook = 0 pOpenFileName.lpTemplateName = 0 pOpenFileName.lStructSize = Len(pOpenFileName) '読取専用ファイルを隠す pOpenFileName.Flags = OFN_HIDEREADONLY _ Or OFN_EXPLORER lngRet = GetOpenFileName(pOpenFileName) GetFileName = Left(pOpenFileName.lpstrFile, _ InStr(pOpenFileName.lpstrFile, vbNullChar) - 1) End Function ** スクレイピング [#l5890357] -[[時給１０００円の事務員さんのための VBA スクレイピング>https://qiita.com/callmekohei/items/d1e1d4c44e753e4d03de]] 2019.5 **アドイン関連 [#c2cf0356] -[[VBAをリボンUIに追加する（インストーラー付き）>http://qiita.com/jp7eph/items/c8bf16b644dee82f9bfe]] 2017.7.17 ** ExcelにGoogle Maps APIで地図を埋め込み、住所検索、拡大／縮小、地図種類変更 [#af08541d] -http://www.atmarkit.co.jp/ait/articles/1409/05/news165.html **開いているファイルの中から名前の左側が引数と合致するファイルを探す [#ye1502e2] '２つ以上あったらエラー Function schFile(name As String) As Workbook Dim cnt As Integer cnt = 0 Set schFile = Nothing Dim bk As Workbook For Each bk In Workbooks Dim ln As Integer ln = Len(name) Debug.Assert (ln > 0) If StrConv(Left(bk.name, ln), vbUpperCase) = StrConv(name, vbUpperCase) Then If Not (schFile Is Nothing) Then MsgBox ("[" & name & "]で始まるファイルが２つ以上あります") End End If Debug.Assert (schFile Is Nothing) '同じ名前で始まるファイルが２つ以上あったらエラーになります Set schFile = bk 'ここですぐは返らない ２つ以上あったらまずいから End If Next If schFile Is Nothing Then MsgBox ("[" & name & "]で始まるファイルが見つかりません") End End If End Function **countifsの数式を元に、同じ条件でフィルタをかける [#db5c2d93] Sub 数式からフィルター(r As Range) Dim strSuusiki As String Dim varPrm As Variant Dim sh As Worksheet Dim ac As Worksheet Dim lngLoop As Long Dim lngColNo As Long Dim strJoken As String Dim rngFil As Range Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set sh = Sheets("hoge") Set ac = r.Worksheet strSuusiki = r.Formula ''該当セルの数式を取り出す strSuusiki = Replace(strSuusiki, "=countifs(", "", , , vbTextCompare) '’余分なところを消す strSuusiki = Replace(strSuusiki, "=countif(", "", , , vbTextCompare) '’余分なところを消す strSuusiki = Replace(strSuusiki, ")", "") '’余分なところを消す varPrm = Split(strSuusiki, ",") '’Countifsのパラメータのみを配列に分割する If Not sh.AutoFilterMode Then ''オートフィルターが付いてない場合 Intersect(sh.UsedRange, sh.Range("10:65535")).AutoFilter '’フィルターをつける End If If sh.FilterMode Then '’フィルターがかかっている状態のときはフィルタークリア sh.ShowAllData End If Set rngFil = sh.AutoFilter.Range For lngLoop = 0 To UBound(varPrm) Step 2 lngColNo = Range(varPrm(lngLoop)).Column ''配列の偶数番目＝検索条件範囲のカラム番号を取得 strJoken = varPrm(lngLoop + 1) ''配列の奇数番目＝検索条件を取得 If InStr(strJoken, """") > 0 Then strJoken = Replace(strJoken, """", "") '’""がある場合は定数（””は消す） Else strJoken = ac.Range(strJoken).Value '’””がない場合はセルへの参照のため参照先の値を取得 End If rngFil.AutoFilter Field:=lngColNo, Criteria1:=strJoken Next Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub **ハイパーリンクをクリックしたら上の行（３行目）にあげる [#y32e4897] Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink) Dim r As Integer r = Target.Range.row If r = 3 Then Exit Sub Else ThisWorkbook.Worksheets(1).Activate Rows("3:3").Select Selection.EntireRow.Insert r = r + 1 Rows(r & ":" & r).Select Selection.Cut Range("A3").Select ActiveSheet.Paste Range("A" & r).Select Selection.EntireRow.Delete End If End Sub **セルの値を文字列として取得したい場合 [#p20b2af8] Cells(i,j).Text ** フィルタ系 [#ma24e96c] -フィルタをクリアする ActiveSheet.ShowAllData -[[行が非表示か判定する>https://www.relief.jp/docs/excel-vba-check-if-row-hidden.html]] --Range.Hiddenプロパティを見る -[[オートフィルタ適用後に表示されている行のみを対象に処理を行う>https://www.blackcat.xyz/article.php/ProgFAQ-Xls_ProcessToCellAfterAutoFill]] ** 現在見ているブックの全シートから_YMDHMSという値の入ったセルをすべて探し、その下にあるセルにフォーマットを設定する [#afb8f6b1] Sub 日付のフォーマット修正() Debug.Print ("フォーマット修正開始") Dim bk As Workbook Dim sht As Worksheet Set bk = ActiveWorkbook Dim i As Integer For i = 1 To bk.Worksheets.Count Set sht = bk.Worksheets(i) With sht .Activate .Cells(1, 1).Select Dim r As Range Set r = Cells.Find(What:="_YMDHMS", After:=ActiveCell, LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, MatchByte:=False, SearchFormat:=False) If Not r Is Nothing Then Dim firstPos As String firstPos = r.Address Do Dim s As String .Cells(r.row, r.Column).Select If Trim(.Cells(r.row + 1, r.Column)) <> "" Then s = .Cells(r.row, r.Column) Debug.Print (.Name & ":" & r.row & "," & r.Column & "," & s) .Cells(r.row + 1, r.Column).NumberFormatLocal = "yyyy-mm-dd hh:mm:ss" .Cells(r.row + 1, r.Column).HorizontalAlignment = xlLeft Dim rcol As Range Set rcol = .Columns(r.Column) rcol.AutoFit End If Set r = Cells.FindNext(r) DoEvents Loop While (r.Address <> firstPos) Else 'そもそもない End If End With Next MsgBox ("OK") End Sub **今選択しているシート [#y63ffaf8] -Application.SelectedSheets を参照する **「名前」の全消し [#l1b923d9] -メニューから消していると一回に１つしか消せなくて面倒なので、以下のマクロで for i = ActiveWorkbook.Names.Count to 1 step -1 ActiveWorkbook.Names(i).Delete Next ** パスワード付きでブックを保存する [#fb962dce] ActiveWorkbook.SaveAs Filename:= _ "hoge.xls", FileFormat:= _ xlExcel8, Password:="anestec", WriteResPassword:="", ReadOnlyRecommended _ :=False, CreateBackup:=False **手っ取り早くExcelシートの一覧を得るには [#mb3fd2e2] -ALT+F11を押下(VBAエディタが起動) -CTRL+Gを押下(イミディエイトウインドウが起動) For Each i In ThisWorkbook.Sheets: debug.print i.name : next i をタイプしてEnterを押下 **［Esc］キーによるExcel VBAの実行中断を防止する [#jd547d76] -http://www.atmarkit.co.jp/fwin2k/win2ktips/1437disescexcl/disescexcl.html Application.EnableCancelKey = xlDisabled **互換性チェックのダイアログが出るのを抑制 [#r83ca239] -Office2007で .xlsファイルを保存しようとしたときに出るダイアログを抑制したい場合は、上書き確認の抑制と同じように Application.DisplayAlerts=False とする **Excelで特定の値になったときのアクション [#l5ea8ee5] -特定のセルに特定の値が入力されたときにマクロを自動的に実行するには？ --http://www.asahi-net.or.jp/~zn3y-ngi/YNxv9c7.html --WorkSheet_Changeのイベントプロシージャに処理を書けば良い。当然ながらExcelの設定でマクロ実行を許可しておく必要はある（オプションのセキュリティ設定） **ツリービューコントロール [#d09d738e] -[[Tree View Controlの組み込み>http://officetanaka.net/excel/vba/treeview/01.htm]] --「ツール」-「その他のコントロール」から「Microsoft TreeView Control」を選択 -http://www.f3.dion.ne.jp/~element/msaccess/AcTipsFrmUsingTreeView1.html -http://www.tsware.jp/study/indexv10.htm -http://www.int21.co.jp/pcdn/vb/noriolib/vbmag/9710/aki/ **VBA コンパイルエラーと実行時エラー [#xb623945] -http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_200_020.html -Excel2002からある模様 -コンパイルの機能はタイプミスなどのチェックをするためのものと考える **CSVをUTF-8で保存する [#l005b80d] -通常のSave機能ではUnicodeまでしか指定できないが、いくつか方法はある -フリーのモジュールを使用する方法 --http://www.vector.co.jp/soft/winnt/prog/se320375.html -ADODB.Streamを使う方法 Dim myFileName As String Dim myPath As String Dim NewFileName As String myFileName = ActiveWorkbook.name myPath = ActiveWorkbook.Path Dim outbook As Workbook Set outbook = ActiveWorkbook Dim sht As Worksheet Dim i As Integer For i = 1 To ActiveWorkbook.Worksheets.Count Windows(myFileName).Activate NewFileName = ActiveWorkbook.Worksheets(i).name Set sht = outbook.Worksheets(i) Dim StreamIn As Object Set StreamIn = CreateObject("ADODB.Stream") With StreamIn .Open .Charset = "shift_jis" .Type = 2 .Position = 0 End With Dim StreamOut As Object Set StreamOut = CreateObject("ADODB.Stream") With StreamOut .Open .Charset = "UTF-8" .Type = 2 .Position = 0 End With Dim row As Integer row = sht.UsedRange.Cells(sht.UsedRange.Count).row Dim line As Integer line = sht.UsedRange.Cells(sht.UsedRange.Count).Column Dim fileName As String fileName = myPath & "\" & NewFileName & ".dat" Dim r As Integer For r = 1 To row Dim l As Integer For l = 1 To line - 1 StreamIn.WriteText sht.Cells(r, l) & "," Next StreamIn.WriteText sht.Cells(r, line), 1 Next StreamIn.SetEOS StreamIn.Position = 0 StreamIn.CopyTo StreamOut StreamOut.SetEOS StreamOut.Position = 0 StreamOut.SaveToFile fileName, 2 StreamIn.Close StreamOut.Close Set StreamIn = Nothing Set StreamOut = Nothing Next i -[[エクセルVBAでBOM無しのUTF-8でCSVファイルなどを出力する方法>https://tonari-it.com/excel-vba-utf8n-bom/]] 2016 **Shift JIS文字列をUTF-8に [#be75801e] Public Function encodeUTF8(ByRef strUni As String) As Byte() encodeUTF8 = ADOS_Encode("UTF-8", strUni) End Function Private Function ADOS_Encode(ByVal cset As String, ByRef strUni As String) As Byte() Dim objStm As ADODB.Stream Set objStm = New ADODB.Stream objStm.Open objStm.Type = adTypeText objStm.Charset = cset objStm.WriteText strUni objStm.Position = 0 objStm.Type = adTypeBinary Select Case UCase(cset) Case "UNICODE", "UTF-16" objStm.Position = 2 Case "UTF-8" objStm.Position = 3 End Select ADOS_Encode = objStm.Read() objStm.Close End Function **描画抑制 [#m5c0a9fc] Application.ScreenUpdating = false **シート並べ替えサンプル [#r4181544] -１シート目の2行目2列目からシート名を並べておき、その順番に２番目以降のシートを入れ替えるマクロの例（ちょっとバグってるかも…） Sub シート並べ替え() Dim bk As Workbook Set bk = ThisWorkbook Dim sht As Worksheet Set sht = ActiveSheet Dim names() As String Dim i As Integer 'シート名読み込み Dim j As Integer j = 0 For i = 2 To 1000 'とりあえず1000シートまで If sht.Cells(i, 2) <> "" Then ReDim Preserve names(j) names(j) = sht.Cells(i, 2) j = j + 1 Else Exit For End If Next For i = 0 To UBound(names) Dim wsht As Worksheet Set wsht = bk.Worksheets(names(i)) Call wsht.Move(After:=bk.Worksheets(1 + i)) Next MsgBox ("OK") End Sub **Excelシートアルファベット順並べ替え [#b6d35ae7] -http://park7.wakwak.com/~efc21/cgi-bin/exqalounge.cgi?print+200610/06100285.txt **列幅を合わせる [#oe1773d9] 'ost は対象シート ost.Activate ost.Range(ost.Cells(1, 1), ost.Cells(osr, 8)).Columns.AutoFit -columnsに対して行うのがポイント **マクロのあるブック [#cf43f3f0] -ThisWorkbookで参照 **AddTextBox に渡す座標の渡し方 [#mb19aab1] -http://www.keep-on.com/excelyou/2001lng4/200102/01020461.txt -Cells().Leftとか.Topとかを利用するとよい **ブックのシートインデックスを作る [#h5eba5dc] -最初のシートに「目次」という名前をつけるのであらかじめ用意しておく Sub MakeIndex() Dim s_シート名() As String Dim mokuji As Worksheet Set mokuji = Worksheets(1) mokuji.Name = "目次" '《目次》シート情報 Dim row As Integer Dim col As Integer row = 1 col = 2 ' シート名取得 mokuji.Select Dim J As Integer For J = 1 To Worksheets.Count ReDim Preserve s_シート名(J) s_シート名(J) = Worksheets(J).Name Next J mokuji.Activate ' 取得結果反映 Dim K As Integer For K = 2 To UBound(s_シート名) Dim sht_name As String sht_name = s_シート名(K) If sht_name <> "" Then Dim rnt As Range Set rnt = mokuji.Cells(K, col) mokuji.Hyperlinks.Add _ Anchor:=rnt, _ Address:="", SubAddress:="'" & sht_name & "'!A1", TextToDisplay:=sht_name mokuji.Cells(K, col).Select End If Next K End Sub **シートに画像を取り込み、その占めている範囲の右下セルを得る [#l25d83f6] Dim acs As Worksheet Set acs = ActiveSheet acs.Cells(1, 1).Select acs.Pictures.Insert(画像のpath).Select Dim r As Range Set r = acs.Pictures(1).BottomRightCell **いらないシートを消す [#z5170efa] Application.DisplayAlerts = False '警告抑制 With outbook '本当は３つとは限らないが（Excelの設定によって変わるので）、とりあえず .Worksheets("Sheet1").Delete .Worksheets("Sheet2").Delete .Worksheets("Sheet3").Delete End With --※シート数を０にはできませんので注意 **プログラムの同期的な実行 [#a45e7192] -→Visual Basic(.NET以前)のページを見よ **表示倍率を変える [#kf626c7f] ActiveWindow.Zoom = 75 **ハイパーリンク作成 [#s57ccf65] 表示文字列 = "hoge" アドレス = "http://www.kernel-net.ne.jp/tech/" Range("A1").Select ActiveSheet.Hyperlinks.Add Anchor:=Selection, _ Address:=アドレス, TextToDisplay:=表示文字列 --削除 Range("A1").Hyperlinks.Delete Range("A1").ClearContents **印刷設定 右下にページ数を入れる [#ya0551da] ActiveSheet.PageSetup.RightFooter = "&P/&N" **印刷範囲の設定 [#b21d0bb9] ActiveSheet.PageSetup.PrintArea = "$A$1:$N$83" 'A1形式 Rangeではダメです **RangeからA1形式の文字列を得るには [#k93f604a] str = Cells(row, col).Address **Worksheets.AddのAfter引数などで渡すのはシート名ではない [#a9dd6dbf] -シートの番目でもない。Worksheetのオブジェクトを渡さないといけないので注意 'ブック末尾へのシート追加 Worksheets.Add after:=Worksheets(Worksheets.Count) -Worksheet.Move や .Copyも同様 **VBAでデータが変わった切れ目で改ページしたい [#d805d981] -http://oshiete1.goo.ne.jp/qa1919970.html Worksheets(SheetName).Range("B" + Trim$(Str$(rindex))).Activate ActiveWindow.SelectedSheets.HPageBreaks.Add ActiveCell '改ページ挿入 ActiveWindow.SelectedSheets.VPageBreaks.Add ActiveCell **印刷改ページを調整する [#p8c34944] '印刷ブレーク位置微調整 13桁目だったら右に１つずらす '直接指定できないのだろうか? Function adjust_print(st As Worksheet) As Integer Debug.Print (st.Name) st.Activate st.Cells(1, 14).Select 'これでは変わってくれないようだ If st.VPageBreaks.Count = 0 Then st.VPageBreaks.Add st.Range("N1") Else st.VPageBreaks(1).Location = st.Range("N1") End If 'こうしないとあわせられないのだろうか? If st.VPageBreaks(1).Location.Column = 13 Then ActiveWindow.View = xlPageBreakPreview ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1 ActiveWindow.View = xlNormalView End If st.Cells(1, 1).Select adjust_print = 0 End Function Sub 印刷位置合わせ() ' Dim shts As Sheets Set shts = ActiveWorkbook.Worksheets Dim i As Integer Dim st As Worksheet '対象シート毎 For i = 4 To shts.Count Set st = shts(i) Call adjust_print(st) DoEvents Next End Sub **CSV形式で保存する [#wd906960] ActiveWorkbook.SaveAs Filename:="hoge.csv", FileFormat:=xlCSV, CreateBackup:=False **データのある最後の行を返す [#i2c480c9] e=Worksheets("sheet1").Range("A1").End(xlDown).Row もしくは e=Worksheets("sheet1").Range("A65536").End(xlUp).Row 'データ中に空き行がある場合 -上のやり方では、列なら２列以上ないと256が返ってしまうので、下記のようにやる方がいいようだ。 Dim row As Integer row = sht.UsedRange.Cells(sht.UsedRange.Count).row Dim line As Integer line = sht.UsedRange.Cells(sht.UsedRange.Count).Column -このやり方について[[こちらのblog>http://d.hatena.ne.jp/takayukis/20090329/1238296405]] でご指摘あり。感謝 これは、データの入力の有無に関わらず、セルの一部に書式設定などがされていれば、 有効な範囲として値を返します。 すっきりとしていて、うまく行きそうですが、実は落とし穴になっています。 **ゴールシークを実行させる [#l2d08fb3] 'E3の値が0になるようにB3を変化させる場合 Range("E3").GoalSeek Goal:=0, ChangingCell:=Range("B3") **ブックを開いてシート毎になにかするサンプル [#a3c4ba90] Function prcBook(bk As String) As Integer Debug.Print ("-------book:" & bk & "スタート---------------------") Dim wbk As Workbook '指定 xls を開く 'Set wbk = Application.Workbooks(bk) Set wbk = Workbooks.Open(bk) wbk.Activate Dim cnt As Integer cnt = wbk.Worksheets.Count Debug.Assert (cnt > 0) Dim i As Integer For i = 1 To cnt Dim wst As Worksheet Set wst = wbk.Worksheets(i) Call prcSheet(wst) Next wbk.Close Debug.Print ("-------処理終わり---------------------") End Function ** VBAプロジェクトをロックする [#i2a1b4c0] -[[VBAのプロジェクトにパスワードを設定する:VBE(Visual Basic Editor)>https://www.relief.jp/docs/017816.html]] 2012 --プロジェクトのプロパティで「保護」シートで設定する ** VBAファイルのデータ構造 [#h90d8d88] -[[Evil Clippy: MS Office maldoc assistant | Outflank>https://outflank.nl/blog/2019/05/05/evil-clippy-ms-office-maldoc-assistant/]] 2019 --https://github.com/outflanknl/EvilClippy --VBAのパスワード外すツール --バイナリは用意されてないのでソースからコンパイルする必要がある。 Make sure you have Visual Studio installed. Then execute the following command from a Visual Studio developer command prompt: csc /reference:OpenMcdf.dll,System.IO.Compression.FileSystem.dll /out:EvilClippy.exe *.cs -[[[MS-OVBA]: Office VBA File Format Structure | Microsoft Docs>https://docs.microsoft.com/en-us/openspecs/office_file_formats/ms-ovba/575462ba-bf67-4190-9fac-c275523c75fc]] 2022.2 -[[OpenMCDF is a 100% .net / C# component that allows developers to manipulate Microsoft Compound Document Files (also known as OLE structured storage).>https://github.com/ironfede/openmcdf/]] 2022.5
