|
× [PR]上記の広告は3ヶ月以上新規記事投稿のないブログに表示されています。新しい記事を書く事で広告が消えます。 |
 |
|
Option Explicit
subステータスバーに表示1() Dim l As Long For i = l To 100 Application.StatusBar=i&″回目の処理をしています…″ Next i Application StatusBar = False '↑これをクリア(False)に戻さないと、画面と閉じるときの保存ダイアログとかでなくなることがあるので注意! End Sub Subステータスバーに表示0 '徐々に伸びるプログレスバーを真似る Dim : As Long For i = l To 20000 1f i Mod 1000 = O Then Range(″Al″) = i Applicat:on.StatusBar〓″処理中.…″&Str:ng(int(i/1000),″■″) End lf Next : Applicatlon.StatusBar = False End Sub Subステータスバーの表示状態と合わせて0 '/現在のステータスバーの表示状態を保持 Dim statusBarVisible As 3oolean '…→True/False statusBarVisible = Application.DisplayStatusBar Application.DisplayStatusBar〓True 'ステータスバーを表示 Application.StatusBar=″処理中です。お待ちください。(^_^v)″ Appl:cation.Wait Now + TimeValue(″00:00:05″) '5澤少4争窃発 Application.StatusBar=Fa:se 'ステータスバーをクリア Application.DisplayStatusBar=statusBarVisible 'ステータスバーの表示状態を元に戻す End Sub PR |
|
|
“ject.11・運 | | ‐ ∵了 Option Explicit ‐ ′ 轟面|オ|ブジェクトの選択011 ActiveSheet.Shapes.Ran音o(″Button lr).Select [lig:|I Actiど僣もhl:詭斃量を「p'Siltem.Name ― X :塾●:‐オブ|ジ|=―ク|卜鷲瑚H騰錮断覆)| ActiveSheet.Shapes.Range(Array(″Button l″, ″ButtOn 2″)).Select End Sub ‐ 峨L副轟肇桑島3_[ォブジェクトの選択と表示]で表示される MsgBox Application.Caller End Sub 轟な|マタ凛|ボタンを割縁01- ActiveSheet.Shapes.Rangё(Array(″出カボタン″,″完了処理ボタン″)).Delete End Sub |
|
|
Find …・1 0ption Explicit Sub検索1() Range(″G:G″).Find(What:=″USD″).Select '見つかつたセルを選択 End Sub Sub検索2() Dim lngYLine As Long Dim intXLine As integer Dim Obj As Object Set Ob」=WorkSheets(″Sheetl″).Celis.Find(″りんご″,LookAt:〓xlWhole) '全て一致/一部一致は、LookAt:=xlPart MsgBox″りんごは見つかりませんでした。″ Else ingYLine = Worksheets(″Sheetl″).Cells.Find(″りんご〃, LookAti〓xlWhole).Row intXLine = Worksheets(″Sheetl″).Cells.Find(″りんご″, LookAt:=xlWhole).Oolumn MsgBox″りんごは、″+CStr(lngYLine)+″行日の″_ +CStr(intXLine)+″列目にあります″ End lf End Sub Sub検索3() '検索がエラーになる(見つからない)と実行時エラーになる D:m x As String Dim y As Long x=″JPYあ″ 'OK y = Oolumns(3).Find(What:=x, LookAti〓xlWhole).Row y 〓 Oolumns(″G″).Find(Whati=x).Row y = Oolumns(″C:G″).Find(What:=x).Row Oolumns(″C:C″).Find(x).Select 'エラー 'y 〓 Columns(″3″).Find(what:=x).Row 'y = Oo!umns(C).Find(what:=x).Row MsgBox y 'LookAt:〓xlPart一部が一致するセルを検索 'LookAt:=xlWhoie全てが一致するセルを検索 '※検索範囲に結合セルがある場合は、結合セルをすべて含んだ範囲を指定すること End Sub Sub検索4() Dim f As Var!ant Dim e As Varlant Dim l As Var:ant '上表の空白行を削除 f = Range(″A:A″).Find(What:=″1″).Row '表の1行日 , eM:g::II♀(1'″1)・in:(XIDown).Row '表の最終行 For l = f To e lf Cells(1, 2) = ″″ Then Exit For Next Rows(i & ″:″ & e).Delete '下表の空白行を削除 e=ActiveSheet.UsedRange.Rows.Oount 'シートの利用最終行 f〓Range(Cells(:,1),Cells(e,1)).Find(Whatl=″1″).Row'表の1行日 e〓Ceils(f,1).End(xlDown).Row '表の最終行 ' MsgBox f & ″ ″ & e For ! 〓 f To e lf Cells(i, 2) 〓 O Then Exit For Next Rows(i & ″:″ & e).Delete Find ―'2 Range(Cells(5, 1), Celis(: - 1, 12)).Select End Sub Sub検索5() Range(″C:C″).Find(Whati=″USD″).Offset(0, 1).Select End Sub Sub検索置換1() '日付データの置換 Dim day(2) As Date 'コ巨ヨ妻: ″ day(1) 〓 ″2015/10/2″ day(2) = ″2015/10/3″ Cells.Replace What:=day(1), Replacementi=day(2), LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormati=False End Sub Sub検索置換2() 'ワークシートの置換表を利用 '「特例1」セル範囲を参照置換、該当しなかつたら「特例2」セル範囲を参照置換 e(1)=Range(″A10″).End(xlDown).Row '表の最終行 For : 〓 10 To e(1) lf lsError(Application.Match(Cells(1,j),ThisWorkbooko Worksheets(″参照データ″).Range(″特例1″),0))Then Else Ce!ls(i, j).Value = Application. index(ThisWorkbook.Worksheets(″彪歩賢瞑テ゛…夕″).Range(″牛キタ刑2″), _ App:lcation.Match(Cells(1, j), ThisWorkbook.Worksheets(″ゼ歩曼瞑テ゛―夕″).Range(″中キ椰″) ,0),0) End lf Next End Sub Subループ0 i=1 Do While Cells(i, 1) く〉 ″ABC″ lf i = Cells.Rows.Oount Then 'シート終端に達したら、ループを抜ける Exit Do End lf i〓i+1 Loop For i = x To 6 tmp = Split(Cells(1, 1), vbLf) Cells(i, 2) = tmp(0) tmp 〓 Split(tmp(1), ″: ″) Cells(i, 3) = tmp(1) Next i End Sub Subフィルタの設定0 Dim j As Long j=Range(″B4″).End(xlDown)Row'最下行取得 , Range(Cells(411),Cells(j,22)).AutoFilter Field:=2,Criterial:=″◇レポ取引″ 'フィルタリング Rows(″5:″&j).Delete 'フィルタリング結果(見えている)行だけを削除 l:[早;`:illi.(lhnlを'(″:ill:sl:143'|キLl:「♀「1:leli:|:|」:=2 1:;:|サ♭多|サンgillミ:3 Range(″Al″).AutoFilter 'フィルタ解除 End Sub Subフィルタリング状態でのコピー0 'フィルタリング状態で見えている行だけをコピー 'ただし、貼付先はフィルタリングされないので注意 '要確認 Fi nd - 3 Range(″AM4:AM1500″).Select 'いらない? Selection.SpecialCel:s(xlCellTypeVisible) Select Selection.Copy Range(″L4〃).Select Selection PasteSpecial Paste:=xlPasteVaiues, operation:=xlNone, Sk:pBlanks:=Fa:se, Transpose:=False End Sub Subフィルタリング後削除0 Dim r As Range 'オートフィルタ 抽出条件″=″(空欄) Range(″A9″).AutoFilter Field:=1, Criterial:=″=″ 'MsgBox″条件Aで抽出しました″ 'rに項目行(A9)は消さないので、A10～A列最終行の"見えているセル"の値をセットしその値をクリア Set r 〓 Range(Range(″A10″), Range(″A″ & Rows Count).End(xlUp)).SpecialCe::s(xlCellTypeVisible) r ClearContents 'MsgBox″可視セルをクリアしました″ 'オートフィルタクリア Range(″A4″) AutoFilter Field:=1 ''オートフィルタを解除 'Range(″Al″).AutoFilter 'MsgBox″ォートフィルタを解除しました″ ''rにセットした範囲で空白セルのある行(A列がクリアされた範囲)を削除し、上に詰める 'r.SpecialCel:s(xlCellTypeBlanks).EntireRow.Delete 'MsgBox″条件Aのあつた行を削除し、上に詰めました″ End Sub SubオートフィルタのONOFFの照会0 1f ActiveSheet.AutoFilterMode Then Range(″Al″).AutoFilter MsgBox″設定されていましたので、解除しました。″ Else Range(″Al″).AutoF:lter MsgBox″設定されていませんでしたので、設定しました。″ End if End Sub Subフィルタリングされているかの照会0 1f ActiveSheet.AutoFilter∥ode Then lf ActiveSheet.AutoFIlter.FilterMode Then MsgBox″絞り込まれています″ Else MsgBox″絞り込まれていません″ End lf End lf End Sub Subエラー値の取得0 1f VarType(ActiveCell.Value) = 10 Then lf ActiveCell.Value = CVErr(xlErrValue) Then MsgBox ″#VALUEl″ Else ヽ MsgBox″違うエラー″ End lf End lf . lf lsError(ActiveCell Value) Then lf ActiveCell.Value = CVErr(x:ErrValue) Then MsgBox ″#VALUEl〃 Else MsgBox″違うエラー″ End lf End if 'VarTypeは値の内容を返す。 'エラー値は10 'CVErrはエラーの内容を特定する Fi nd ―-4 'CVErr(xlErrValue)は #VALUE! 'VarTypeは:sErrorでもよい lf lsError(ActiveCell Value) Then lf ActiveCell.Value 〓 CVErr(xlErrValue) Then MsgBox ″#VALUE!″ Else MsgBox″違うエラー″ End lf End !f End Sub Sub並べ替え_Sort O ′ '①並べ替えの条件の設定 With ActiveSheet.Sort.SortFields .Clear '現在の並べ替え条件(パラメータ)をクリア .Add Keyl:〓Range(″C2″), Orderl:=xlAscending, DataOptionl:=xiSortNormal, _ Key2:=Range(″E2″), Order2:=xlDescending, DataOption2:=xlSortNormal, _ Key3:=Range(″W2″), Order3:〓xlAscending, DataOption3:=xlSortTextAsNumbers End With '※各引数の説明(☆省略すると規定値設定になる) 'Key 並べ替えの基準となるフィールド(3種類指定可) 'Order ★x:Ascending:昇順(既定値)、xlDescending:降順(3種類指定可) 'DataOption★xlSortNormaに数値とテキストを別々(既定値)、xlSortTextAsNumbers:テキストを数値データとみなす(3種 類指定可) '②並べ替えの実行その1(★引数を省略すると規定値設定になる) With ActiveSheet.Sort .SetRange Range(″A2:Z100″) '並べ替える範囲を指定 ダぁザeader=xlYes '★xlNo:ヘッダなし(既定値)、xlGuess:ヘッダカシbるかどうかチェック、xlYes:ヘッ .OrderCustom=1 '★ューザー定義の並べ替えリスト内の番号を示す1から始まる整数、省略すると通常 の並べ替えを使用 .MatchCase=False '★False:大文字と小文字を区別しない(既定値)、Truei大文字と小文字を区別 .Orlentation = xlTopToBottom 'り好摂斗SaFtRowsニィ予塵自中菫 各文どあ燃薔雲あ7:;i憲りがな順 ★XIPinYin:中国語の| .Apply '並べ替えを実行 End W:th '②並べ替えの実行その2 Range(″A2:Z100″).Sort Keyl:〓Range(″C2″)0 0rderl:=xlAscendin`しHeader:=xlYes End Sub |
|
|
0ption Explicit Subセルの値を取得0 'Range(″Dl″)に「平成28年1月4日」と入力されている場合(日付書式が設定されている) MsgBox Range(″D2″).Value '→2016/01/04(月) …書式で指定された標準?値 MsgBox Range(″D2″)Value2 '→42373 …シリアル値 MsgBox Range(″D2″)Text '→平成28年1月4日 …書式(表示)通りの値 MsgBox Range(″D2″).Formula '→=WORKDAY(TODAY O,-1,休日テーブル)・…数式 '※プロパティを指定しない場合はValueの扱いになる(規定値) End Sub Subセルの値を数値型に変換0 Dim i As integer i = Clnt(″123″) '―→123 i = Clnt(1.5) '―→2 Dim s As Strlng s=″Tips″ '→ェラー '/変換できるときだけ実行する !f lsNumeric(s) 〓 True Then i = Clnt(s) End lf '他の数値型を指定して変換したいときは次の関数を使用 '関数 型 'CByte Byte 'CCur Currency 'CDbl Double 'CDec Decimal 'CLng Long 'CSng Single End Sub Subセル値のコードを取得0 ,糞魚済翌撃裏・こ■はヽ全角文字はシフトJiSコードを取得 MsgBox Asc(″a″) '―→97 MsgBox Asc(〃A″) '→65 纏品炉驚浸み轟考入れ≒盪島は1文字目のコードのみを取得 MsgBox Asc(″[ヨ本″) '一→-27654 End Sub Subセル値を文字コードで出力0 Msg3ox Chr(97) '=→a MsgBox Chr(65) '―→A MsgBox Chr(-27654)'→日 End Sub Sub SU∥関数0 Range(Cells(15, 5), Cells(18, 5)).Select MsgBox Application WorksheetFunction.Sum(Range(Ce:ls(15, 5), Ceils(18, 5))) 嘱鼈i堀F侮拘r化孟鰍魔牟桶良憶計柵猟塵縫計亀。.¨団Q OD・Appl h“山鍋J順歯いⅢ お品ン),p尉l腎bnW°rk山∝fmttb■htthtte“M∝N2つ,Applicat bn Work山∝fmd bnMatcKttt h耐知 |:el♀:|||:[l!|:サ;:l〕:i♀:Fu18';,nttSII`i♀:::∫:ill:∫1:he:セトul:11:ll:Lm,Iをキg:(8:||:t♀;1°|。∥:rb:キ♀:1「甘lCI:,,,S11`lange Else MsgBox ″NO″ End lf Cell … 2 1f Appllcation.WorksheetFunction.Sum(Range(″E15:E18″))= Application.WorksheetFunction.Sum(Range(″J15:J18″)) Then MsgBox ″YES″ EIse MsgBox ″NO″ End if End Sub 鮎bl列番号を調べるo Dim a As Long Dim b As String '列番号取得 a = ActiveCell.Column '列名(アルファベット)取得 …Ce∥sはRange指定でもOK b = Left(Celis(1, a).Address(True, False), lnStr(Cells(1, a).Address(True, False), ″$″)- 1) MsgBox″選択されている列は ″&b&″ です。 ″&vbCrLf&_ ″列番号は ″&ActiveCe∥.Oolumn&″ です。 ″,vbinformation End Sub Subl列名を調べる.0 Dim num As Long num=lnputBox(″列の数字を入力してください″) MsgBox Chr(num + 64) End Sub Sub例番号を取得10 MsgBox ″イ子(Row)署昏=子: ″ & ActiveCell.Row & vbCrLf & ″Fll(Oolumn)籠昏=子: ″ & ActiveCell.Oolumn Debug.Print ″ィテ(Row)署陽=計: ″ & ActiveCell.Row Debug.Print ″Jll(Oolumn)籠野=計 : ″ & ActiveCell.Column End Sub Sub列選択0 Worksheets(″信託ロスキーム(TAKU∥l)″).Activate Co!umns(〃S″).Select End Sub Slb列幅調1整二範囲指定あり0 Range(″A3:G14″).Oolumns.AutoFit 編釜孝鳥87イ響鰍黒魔牝キ濡悔需♂鳥砕iturreltRegiOnプロパティを使う End Sub Sub行列の表示非表示o 'ActiveCell.EntireRow.Hidde x Rows(2).Hidden = True 'o Range(″A10〃).EntireRow.Hidden = True '() End Sub Sしb行の選択1〈) 'フィルタリング後の見えている行のみを選択 Rows(″5:1000″).CurrentRegion.SpecialCells(xlCellTypeVisible).Select Selection.Delete End Sub 壺計摯続,じo Dim e As Variant e = ActiveSheet.UsedRange.Rows.Count Cell - 3 MsgBox e End Sub Subセルの背景色を調べる0 '調べる(イミディエイトに表示) Debug.Print ActiveCell. lnterior Color 'セルに背景色を付ける 'ActiveCe∥.lnterior.Color=(イミディエイトに表示されたコード) End Sub Sub全セル値コピー0 Cells.Copy Range(″Al″).PasteSpecial Paste:=xlPasteValues Application CutCopyMode = False End Sub Sub値コピー0 Range(″A4″).Pastespecial Paste:=xlValues 'x …できるけど、オブジェクトもコピーされる Range(″Al″).Pastespecial Paste:=xlPasteVa:ues 'O ―値のみコピー End Sub Subセルの値をクリップボートに格納0 Dim myCopy As New MSForms.DataObject With myCopy .SetText ActiveCell Value .PutinClipboard End With End Sub Sub WorkDay関数0 :を多ξ]二」|」営l[ristfiI[:バ|ピ:3」lfilil]「[「][111三履「la二.[1『[:1」ずΥ女F:「 ∥::卜E;9,IR`il`1ドEl:L:き",:l:i`:)2″) = Application.WorksheetFunction.WorkDay(Date, -1, ThisWorkbook.Worksheets(″ゼ歩 ;∥l:∥::,9:〕∫〔l`りj「7」liき)Range(″L2″) = Application.Run(″ATPVBAEN.XLAIWorkDay″, Date, -1, ThisWorkbook.Worksheets(1 'ワークシートに代入する数式 =WORKDAY(TODAY O,-1,参照デ…夕!$E$2:SE$36) End Sub Sub日付指定0 MsgBox Date 朧出I路撥訃|:1能鮮能ヨ1脚∥鵬ヨ18 End Sub Sub範囲を取得0 '選択したセル範囲を表示 2::i:|::::11:曇|「::|:|:|:llilll!:lll:i:i:|ll!!||::::|:illiillilsOlute:=F:lse) ||||::::::.xism]Sheetl!$A End Sub ・ Sub範囲指定1() '続いている範囲? ←空白を含む入力されている範囲らしい 相細 日月月 今当前 Cell - 4 Range(Range(″B9″), ActiveCell.SpecialCells(xlLastCel!)).Select End Sub Sub範囲指定2() '現在見えているセル範囲を返す MsgBox ActiveWindow.VisibleRange Address End Sub Sub改行コニドでセル分割する0 Dim x,y As Long '始まりの行列番号 Dim i, j As Long Dim tmp As Var:ant 'アクティブセルから始まる x = ActiveCell.Row y = ActiveCell.Oolumn 'MsgBox x & vbLf & y i=x 」=y Do While Cel:s(1, j) 〈〉 ″″ tmp = Split(Cells(i, j), vbLf) Cells(i, j + 1) = tmp(0) Cells(i, j + 2) = tmp(1) i=i+1 Loop End Sub Subl文字色を一部変更0 '7文字日から6文字を赤色にする Range(″B2〃).Characters(Start:=7, Lengthi=6)。Font.Oolorlndex = 3 End Sub Sub名前セルを作る0 Range(″Al″).Name = ″イ計言十筆色Eヨ″ End Sub Sub名前セルの指定0 Rfま多探省阜ニワ捻考麗よnまたは名前の範囲がブックの場合 品よ多砲(1長3角栗婁多甲釜た夏卜の場拿 Range(″Sheetl l名前セル2″).Select 'ブック外から Range(″∥yマクロ.xlsm!名前セル1″).Select Range(myBK.Name&″!名前セル1″).Select 'ブックを変数に格納 Iぶよ多怖弁長昇ξ研昴露尾ど者石書8褥夕).select Range(″'[∥yマクロ.xlsm]SNIF(1)'!名前セル2″).Select End Sub Sub名前セルの名前を取得0 '単一セルのみ、範囲はムリ MsgBox″セルの名前:〃&ActiveCell.Name.Name End Sub Sub名前セルの行列番号の取得0 Range(″青い表″).Select Cells(Range(〃青い表″).Row,Range(″青い表″).Oolumn).Select MsgBox″表のセル範囲:″&Range(″青い表″).Address MsgBox″表の起点の行番号:″&Range(″青い表″).Row ∥::::I“雲:13,:寡l`Pフl『卜11「g:(9讐|]1:髪`∫扁:1露:なし1:lumn MsgBox″表の列数:″&Range(″青い表″).Oolumns.Oount MsgBox″表の終点の行番号:″&Range(″青い表″).Row+Range(〃青い表〃).Rows.Oount-1 MsgBox″表の終点の列番号:″&Range(″青い表″).Oolumn+Range(″青い表″).Oolumns.Oount-1 End Sub Sub名前セルをすべて削除0 '/名前付きセルから名前をすべて削除する Dim n As Name For Each n in ActiveWorkbook.Names On Error Resume Next'エラーを無視 n.Delete Next End Sub Sub文字列を日付型にする0 '見た目が日付ならこれ ∥sgBox CDate(″2000/08/04″) '8ケタの数字ならこれ Msg3ox Format(″20150727″, ″@@@@/@@/@@″) End Sub |
|
