関連Web †
Tips †スクレイピング †アドイン関連 †
ExcelにGoogle Maps APIで地図を埋め込み、住所検索、拡大/縮小、地図種類変更 †開いているファイルの中から名前の左側が引数と合致するファイルを探す †'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の数式を元に、同じ条件でフィルタをかける †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行目)にあげる †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 セルの値を文字列として取得したい場合 †Cells(i,j).Text フィルタ系 †
現在見ているブックの全シートから_YMDHMSという値の入ったセルをすべて探し、その下にあるセルにフォーマットを設定する †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 今選択しているシート †
「名前」の全消し †
パスワード付きでブックを保存する †ActiveWorkbook.SaveAs Filename:= _ "hoge.xls", FileFormat:= _ xlExcel8, Password:="anestec", WriteResPassword:="", ReadOnlyRecommended _ :=False, CreateBackup:=False 手っ取り早くExcelシートの一覧を得るには †
[Esc]キーによるExcel VBAの実行中断を防止する †
互換性チェックのダイアログが出るのを抑制 †
Excelで特定の値になったときのアクション †
ツリービューコントロール †
VBA コンパイルエラーと実行時エラー †
CSVをUTF-8で保存する †
Shift JIS文字列をUTF-8に †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 描画抑制 †Application.ScreenUpdating = false シート並べ替えサンプル †
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シートアルファベット順並べ替え †シート上のシェイプの色をまとめて黒に戻す例 †Sub Macro1() Dim i As Integer Dim acs As Worksheet Set acs = ActiveSheet For i = 1 To acs.Shapes.Count Dim shap As Shape Set shap = acs.Shapes(i) With shap acs.Activate shap.Select DoEvents If (shap.Type = msoAutoShape) Then If shap.AutoShapeType = msoShapeMixed Then 'コンピュータ図とか ElseIf shap.AutoShapeType = msoShapeRoundedRectangle Then '角の丸い四角 Selection.Font.ColorIndex = xlAutomatic End If ElseIf shap.Type = msoLine Then Selection.ShapeRange.Line.ForeColor.SchemeColor = 64 Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255) ElseIf shap.Type = msoTextBox Then Selection.Font.ColorIndex = xlAutomatic End If End With Next End Sub 列幅を合わせる †'ost は対象シート ost.Activate ost.Range(ost.Cells(1, 1), ost.Cells(osr, 8)).Columns.AutoFit
マクロのあるブック †
シェイプを最背面に移動 †Selection.ShapeRange.ZOrder msoSendToBack '最背面に移動 AddTextBox に渡す座標の渡し方 †
ブックのシートインデックスを作る †
シートに画像を取り込み、その占めている範囲の右下セルを得る †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 いらないシートを消す †Application.DisplayAlerts = False '警告抑制 With outbook '本当は3つとは限らないが(Excelの設定によって変わるので)、とりあえず .Worksheets("Sheet1").Delete .Worksheets("Sheet2").Delete .Worksheets("Sheet3").Delete End With
プログラムの同期的な実行 †
表示倍率を変える †ActiveWindow.Zoom = 75 ハイパーリンク作成 †表示文字列 = "hoge" アドレス = "http://www.kernel-net.ne.jp/tech/" Range("A1").Select ActiveSheet.Hyperlinks.Add Anchor:=Selection, _ Address:=アドレス, TextToDisplay:=表示文字列
印刷設定 右下にページ数を入れる †ActiveSheet.PageSetup.RightFooter = "&P/&N" 印刷範囲の設定 †ActiveSheet.PageSetup.PrintArea = "$A$1:$N$83" 'A1形式 Rangeではダメです RangeからA1形式の文字列を得るには †str = Cells(row, col).Address Worksheets.AddのAfter引数などで渡すのはシート名ではない †
VBAでデータが変わった切れ目で改ページしたい †印刷改ページを調整する †'印刷ブレーク位置微調整 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 CSV形式で保存する †ActiveWorkbook.SaveAs Filename:="hoge.csv", FileFormat:=xlCSV, CreateBackup:=False データのある最後の行を返す †e=Worksheets("sheet1").Range("A1").End(xlDown).Row もしくは e=Worksheets("sheet1").Range("A65536").End(xlUp).Row 'データ中に空き行がある場合
ゴールシークを実行させる †'E3の値が0になるようにB3を変化させる場合 Range("E3").GoalSeek Goal:=0, ChangingCell:=Range("B3") ブックを開いてシート毎になにかするサンプル †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 |