6-3 Excel97・Excel2000・Excel2003 HPから残し
6-3(1) オブジェクト名とセル位置取得
○●●下記マクロはオブジェクトがどのセルにあるか取得し、別シ−トへオブジェクト
のみ貼り付ける場合等に使用できる。
Dim obg(2, 50) As String 'オブジェクト名
'
Sub 例299()
'オブジェクトチェック
i = 0
For Each ex In ActiveSheet.Shapes
obg(0, i) = ex.Name
obg(1, i) = ex.TopLeftCell.Row
obg(2, i) = ex.TopLeftCell.Column
Msg = "オブジェクト名 " & obg(0, i) & _
": Cells(" & obg(1, i) & "," & obg(2, i) & ")"
celad = MsgBox(Msg, 1, "セル位置")
If celad = 2 Then
Exit Sub
End If
i = i + 1
Next
End Sub
・下側のセルは"BottomRightCell"で取得
6-3(2) 拡張子の取得
○○●拡張子の取得はExcel2000で追加されたInStrRev関数で容易に取得出来る。
Sub 例2917)
fff = Application.GetOpenFilename(Title:="ファイル指定")
i = InStrRev(fff, ".")
ext = Mid(fff, i)
MsgBox ext
End Sub
●●●下記はInStrRev関数を使用しないケ−ス（Excel95/97）
Sub 例2917a()
fff = Application.GetOpenFilename(Title:="ファイル指定")
i = 0: ia = 1
Do
i = InStr(ia, fff, ".")
ia = InStr(i + 1, fff, ".")
If ia = 0 Then
ext = Mid(fff, i)
End If
Loop Until ia = 0
MsgBox ext
End Sub
本例は最後に出てきた"."以降を拡張子としています。
6-3(3) 相対アドレスの取得
●●●Excelでは相対アドレスを使用しないが、HTMLファイルをマクロで各種
処理する場合は必要となる。下記例は「検索エンジンもどき：KIengine」を作成
した時考えたので紹介します。
■ このマクロは始めに指定したフォルダ−を基点として、２回目以降に指定した
フォルダ−の相対アドレスを取得（なお指定はファイルを1個指定して下さい）。
Dim fff1 As String
Dim fff2 As String
Dim kai As Integer
Dim f(1, 50)
Sub eeee1()
kai = 0
eeee2
kai = 1
eeee2
End Sub
Sub eeee2()
'ダイアログ表示
If kai = 0 Then
fsitei = "基準ファルダ−指定"
Else
fsitei = "相対アドレスをチェックするファルダ−指定"
End If
fff = Application.GetOpenFilename(Title:=fsitei)
If fff = "False" Then
MsgBox "ファイルを１個指定して下さい"
End
End If
dai = fff
If kai = 0 Then
fff1 = fff
k = 0
Else
fff2 = fff
k = 1
End If
For i = 1 To 20: f(k, i) = "": Next
i = 1: ssa1 = 0: fname = ""
Do
ssa = InStr(1, dai, "\", 1)
ssa1 = ssa1 + ssa
If ssa > 0 Then
dai = Mid(dai, ssa + 1)
ssb = InStr(1, dai, "\", 1)
If ssb > 0 Then
f(k, i) = Left(dai, ssb - 1)
End If
i = i + 1
End If
Loop Until ssa = 0
If kai = 0 Then
Exit Sub
End If
'相対パス設定
sad = ""
For i = 1 To 50
If f(0, i) <> f(1, i) Then
If f(0, i) = "" Then
sad = sad & f(1, i) & "/"
Else
If f(1, i) = "" Then
sad = sad & "../"
Else
sad = sad & "../"
For j = 49 To i Step -1
f(1, j + 1) = f(1, j)
Next
End If
End If
Else
If f(0, i) = "" Then
Exit For
End If
End If
Next
'メッセ−ジ
fname = Mid(fff2, ssa1)
msg = "基点となるファルダ−" & fff1 & Chr$(10) & _
"確認したいファルダ−" & fff2 & Chr$(10) & _
"相対アドレスは " & sad & fname & Chr$(10) & Chr$(10) & _
"(他のフォルダ−も確認しますか）"
kesu = MsgBox(msg, 4, "相対アドレス")
If kesu = 6 Then
eeee2
Else
End
End If
End Sub
6-3(4) ワ−クシ−ト上のデ−ダ数量取得
●●●
ワ−クシ−トにあるデ−タ数量を知る必要があり作成。
Sub Macro1()
Range("A4").CurrentRegion.Select
cel1 = Selection.Cells.Count
cel2 = Selection.SpecialCells(xlBlanks).Count
Range("A1").Select
MsgBox cel1 - cel2
End Sub
6-3(5) デ−タベ−スのHTML形式に変換(配列変数使用)
○●●
・Sheet1にあるデ−タベ−スをSheet2へWebで表示できるデ−タに変換します。
・実際にWebで表示する場合は、Sheet2を拡張子「.prn」で保存し、Excelを終了
してから、ディスクトップのマイコンピュ−タ-から対象の「***.prn」を
「***.html」に変えて下さい。
・上記の拡張子変換はマクロで簡単に行なうことできますが、下記マクロは
では省略してあります。
・なお、26-52項（ＣＳＶファイル高速読み取り）、この29-54項及び
自動HTML変換を、サンプルNo[19]にまとめましたので、必要な方は
ダウンロ−ドして使用して下さい。
※ 配列変数を使用してHTMLに変換したこの方式は、時間的には高速に
なりますが、文字フォントやセルの背景色等の変換は出来ません。
（Excelワ−クシ−トの内容をHTML変換はサンプルマクロ「KIweb」で
出来ます。
Dim i As Integer '数字カウント
Dim j As Integer '数字カウント
Dim cend As Integer '列
Dim rend As Integer '行
Dim hro As Integer 'html行
Dim dbas As String '１行分のデ−タ
Dim dt() As String
Dim tdat As Variant
Sub 例2954()
Application.ScreenUpdating = False
Sheets("Sheet2").Select
Columns("A:A").ColumnWidth = 255
'ヘッダ−部書込み
hro = 1: Cells(hro, 1) = "<HTML>"
hro = hro + 1: Cells(hro, 1) = "<HEAD>"
hro = hro + 1: Cells(hro, 1) = "<TITLE>" & dai & "</TITLE>"
hro = hro + 1: Cells(hro, 1) = "</HEAD>"
hro = hro + 1: Cells(hro, 1) = "<!-- このファイルは、KIDBhtml" & va & "で作成されました。-->"
'バックカラ−
hro = hro + 1: Cells(hro, 1) = "<BODY BGCOLOR=#ffffbf>"
'表作成
Sheets("Sheet1").Select
tdat = Range("A1").CurrentRegion.Value
rend = UBound(tdat, 1)
cend = UBound(tdat, 2)
'テ−ブル作成
dbas = "<TABLE BORDER>"
表貼付
For i = 1 To rend
Sheets("Sheet1").Select
Application.StatusBar = "HTML変換中---- " & i & "/" & rend
ReDim dt(4)
dt(0) = "<tr>"
For j = 1 To cend
If Trim(tdat(i, j)) = "" Then
tdat(i, j) = " " 'ﾌﾞﾗﾝｸセルにhtmlﾌﾞﾗﾝｸ
End If
If j < 6 Then
dt(0) = dt(0) & "<td>" & tdat(i, j) & "</td>"
ElseIf j < 12 Then
dt(1) = dt(1) & "<td>" & tdat(i, j) & "</td>"
ElseIf j < 18 Then
dt(2) = dt(2) & "<td>" & tdat(i, j) & "</td>"
ElseIf j < 24 Then
dt(3) = dt(3) & "<td>" & tdat(i, j) & "</td>"
Else
dt(4) = dt(4) & "<td>" & tdat(i, j) & "</td>"
End If
Next
For n = 0 To 4
If dt(n) <> "" Then
dbas = dt(n)
表貼付
End If
Next
dbas = "</tr>"
表貼付
Next
'最終処理
Sheets("Sheet2").Select
hro = hro + 1: Cells(hro, 1) = "</table>"
hro = hro + 1: Cells(hro, 1) = "<BR>"
'更新日
hro = hro + 1: Cells(hro, 1) = "作成日： " & Date & "<BR>"
hro = hro + 1: Cells(hro, 1) = "" & "<BR>"
hro = hro + 1: Cells(hro, 1) = "</BODY>"
hro = hro + 1: Cells(hro, 1) = "</HTML>"
Application.ScreenUpdating = True
Sheets("Sheet2").Select
Application.StatusBar = "保存完了"
msg = "ＨＴＭＬへ変換完了。"
kesu = MsgBox(msg, 0, "KIDBhtml")
End Sub
'
Sub 表貼付()
Sheets("Sheet2").Select
hro = hro + 1
Cells(hro, 1) = dbas
End Sub
6-3(6) マクロ内での待ち時間設定例
○●●
他のアプリケ−ションを起動した場合等で、マクロ内に待ち時間
を設定する必要があるケ−スがあるが、本項に待ち時間設定例を記述。
[1] 少し時間を取りたい時使用（PCにより時間が大幅に異なる）
For t1 = 1 To 10000
For t2 = 1 To 1000
Next
Next
[2] ３秒間時間を取った例（DoEventsによりアプリケ−ションは読込んでいる）
timck = Timer + 3
Do
If Timer > timck Then
Exit Do
End If
DoEvents
Loop
[3] １０秒のカウントダウンをセルへ表示した例1
tm = 10
tma = tm: tm2 = 0: tim1 = 0
timck = Timer + tm
Do
If Timer > tim1 Then
Cells(1, 1) = tma
tim1 = Timer + 1
tm2 = tm2 + 1
tma = tm - tm2
End If
If Timer > timck Then
Exit Do
End If
Loop
[4] １０秒のカウントダウンをセルへ表示した例2
tm = 10
For t = tm To 0 Step -1
Cells(1, 1) = t
Application.Wait (Now + TimeValue("00:00:01"))
Next
[5] ４秒間待った例
Application.Wait (Now + TimeValue("00:00:04"))
[6] ２分間を監視した例
tim = Now + TimeValue("00:02:00")
Do
If Now > tim Then
MsgBox "タシムオ−バ−"
Exit Do
End If
’-----実行するマクロ（省略） ---------
Loop
[7] ５秒後にプロシージャ"Macro1"を実行
Application.OnTime Now + TimeValue("00:00:05"), "Macro1"
【戻る】 【Top画面】 【HPへ】