- 追加された行はこの色です。
- 削除された行はこの色です。
#author("2023-06-18T14:52:22+09:00","default:irrp","irrp")
#author("2024-04-15T11:56:47+09:00","default:irrp","irrp")
→ExcelのVBA
# contents
#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]
'2つ以上あったらエラー
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 & "]で始まるファイルが2つ以上あります")
End
End If
Debug.Assert (schFile Is Nothing) '同じ名前で始まるファイルが2つ以上あったらエラーになります
Set schFile = bk
'ここですぐは返らない 2つ以上あったらまずいから
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
*ハイパーリンクをクリックしたら上の行(3行目)にあげる [#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]
-1シート目の2行目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
'本当は3つとは限らないが(Excelの設定によって変わるので)、とりあえず
.Worksheets("Sheet1").Delete
.Worksheets("Sheet2").Delete
.Worksheets("Sheet3").Delete
End With
--※シート数を0にはできませんので注意
*印刷改ページを調整する [#p8c34944]
'印刷ブレーク位置微調整 13桁目だったら右に1つずらす
'直接指定できないのだろうか?
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 'データ中に空き行がある場合
-上のやり方では、列なら2列以上ないと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]] でご指摘あり。感謝
これは、データの入力の有無に関わらず、セルの一部に書式設定などがされていれば、
有効な範囲として値を返します。
すっきりとしていて、うまく行きそうですが、実は落とし穴になっています。