![[PukiWiki]](image/pukiwiki.png "[PukiWiki]")
#author("2023-06-18T14:59:47+09:00","default:irrp","irrp") #author("2024-04-15T11:56:47+09:00","default:irrp","irrp") →ExcelのVBA #contents *正規表現による倍角文字チェック [#rda468e1] Sub CheckFullWidthCharacters() Dim ws As Worksheet Dim cell As Range Dim lastRow As Long Dim fullWidthPattern As String Dim match As Object ' 使用するワークシートを設定 Set ws = ActiveSheet ' C列の最終行を取得 l astRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row ' 全角文字を検出する正規表現パターン f ullWidthPattern = "[^\x00-\x7F]" ' C列のデータを一つずつチェック For Each cell In ws.Range("C1:C" & lastRow) If cell.Value <> "" Then cell.Select ' 正規表現オブジェクトを作成 With CreateObject("VBScript.RegExp") .Global = True .Pattern = fullWidthPattern ' パターンにマッチするかチェック Set match = .Execute(cell.Value) If match.Count > 0 Then ' マッチする場合、セルの背景を赤色に設定 cell.Interior.Color = RGB(255, 0, 0) Else ' マッチしない場合、セルの背景を緑色に設定 cell.Interior.Color = RGB(0, 255, 0) End If End With End If DoEvents Next cell MsgBox ("OK") End Sub *開いているファイルの中から名前の左側が引数と合致するファイルを探す [#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 *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 *シート並べ替えサンプル [#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 *ブックのシートインデックスを作る [#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 --※シート数を０にはできませんので注意 *印刷改ページを調整する [#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 *ブックを開いてシート毎になにかするサンプル [#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 * 現在見ているブックの全シートから_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 * パスワード付きでブックを保存する [#fb962dce] ActiveWorkbook.SaveAs Filename:= _ "hoge.xls", FileFormat:= _ xlExcel8, Password:="anestec", WriteResPassword:="", ReadOnlyRecommended _ :=False, CreateBackup:=False *ハイパーリンク作成 [#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 *データが変わった切れ目で改ページ [#a9524d65] -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 *データのある最後の行を返す [#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]] でご指摘あり。感謝 これは、データの入力の有無に関わらず、セルの一部に書式設定などがされていれば、 有効な範囲として値を返します。 すっきりとしていて、うまく行きそうですが、実は落とし穴になっています。
