![[PukiWiki]](image/pukiwiki.png "[PukiWiki]")
関連Web †
Tips †スクレイピング †アドイン関連 †
ExcelにGoogle Maps APIで地図を埋め込み、住所検索、拡大／縮小、地図種類変更 †開いているファイルの中から名前の左側が引数と合致するファイルを探す †'２つ以上あったらエラー
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の数式を元に、同じ条件でフィルタをかける †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
ハイパーリンクをクリックしたら上の行（３行目）にあげる †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
'本当は３つとは限らないが（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桁目だったら右に１つずらす
'直接指定できないのだろうか?
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
|
