【Excel】入力した月でカレンダーを変化させて、クリックしたエリアの日付を取得する。

月ごとの開始曜日と祝日のちょっとした設定と条件付き書式で、それっぽいのが出来てしまったので、エクセルってすげぇなってなった。

セルをクリックボタンにしたい時は、クリック対象のセルに透明なシェイプを置いてマクロを割してて、Application.callerで押されたシェイプを取得して、シェイプのBottomRightCell.Valueでそのセルの中身を持ってくる、ということをするのが、常套手段。

シート保護掛けるとシェイプも弄れないのでいい感じ。

【Excel/VBA】ドキュメントプロパティがイケメン【完全に自分用】

TANAKAさんいつもありがとうTANAKAさん！！

【参考】http://officetanaka.net/excel/vba/tips/tips122.htm
--------------------------------------------
Public Sub Set_Property(Dfo_Value() As String)
'=====================================
' プロパティ初期セット
'=====================================
Dim wkProp() As Variant, i As Long

Call Setthing_CProp(wkProp) ' エクセルに設定したい↓の内容あれそれを配列にセット

For i = 0 To UBound(wkProp)
wkProp(i, 3) = Dfo_Value(i)　　　 ' で、受け値を追加で入れる
Next

On Error GoTo Err_Me

For i = 0 To UBound(wkProp)
ThisWorkbook.CustomDocumentProperties.Add _
Name:=wkProp(i, 0), _
LinkToContent:=wkProp(i, 1), _
Type:=wkProp(i, 2), _
Value:=wkProp(i, 3)
Next

Call Me_Save ' プロパティ変更は、当然、Workbook.SavedがFalseになる訳なんだが、ユーザーにセーブ判断をさせたくなかったり、セーブさせたくなかったりするために挿入しているプロシージャ

Exit Sub
Err_Me:

Select Case Err.Number
' 既に設定済みプロパティだった
Case -2147467259
Call Chg_Property(CStr(wkProp(i, 0)), wkProp(i, 3))
Resume Next
End Select

End Sub
--------------------------------------------

【Access/Excel/VBA】chr(63)詐欺を倒す。

やめろ、エクセル、やめろー！！

【参考】EXCELにWEBページから貼り付けて利用しています。

HTMLページのテーブルレイアウトからエクセルにデータを張り付けて、１列だけ使おうとすると、空白でも改行でもない謎の文字が張り付いて、SQLでの突き合わせが出来なくなる、という代物。

ちなみに、下記はそもそも、in句（OR的意味の）を作るためにデータをカンマ区切りにするのが目的。

-------------------------------------------------------------
Private Function Chg_Fid_Str(Str As Variant) As String
'============================================
' 読点と改行をカンマに変換する
'============================================
Dim wkAry() As String, i As Long, wkStr As String

wkStr = ""

If Not IsNull(Str) Then

wkStr = Replace(Replace(Str, "、", ","), vbCrLf, ",")
wkAry = Split(wkStr, ",")

wkStr = ""
For i = 0 To UBound(wkAry)
If Trim(wkAry(i)) <> "" Then
If wkStr <> "" Then wkStr = wkStr & ","
wkAry(i) = Trim(wkAry(i))
If AscB(Mid(wkAry(i), Len(wkAry(i)), 1)) = 160 Then wkAry(i) = Left(wkAry(i), Len(wkAry(i)) - 1) ' ←　ココ
wkStr = wkStr & wkAry(i)
End If
Next

End If

Chg_Fid_Str = wkStr

End Function
-------------------------------------------------------------

【Excel/VBA】ワークシート内の全シェイプのテキストを新規シートのA列に書き出す

この間作ったのの逆というか。

この間作ったやつで作った資料のシェイプのテキストを元に、一覧表を作りたくなって作りました。

シェイプにテキストオブジェクト（？）が、あるかどうかをチェックするプロパティがない、だと…？！
仕方ないので、レジュームで回避してます。On Errorが三個あるのがポイント。
めんどうくさいので、それ以外のエラーもResume Next（←

'------------------------------------------------------------------------------
Public Sub morning2013_10_8(tgtWS As Worksheet)
'====================================
' 指定したワークシートの全シェイプを収集し、新しいシートにテキストを書き出す
'
' テキストの無いシェイプは、Err.Number=13を返すので、
' 該当シェイプ名を一列ずらして入力し、レジュームする
'====================================
Dim WS As Worksheet
Dim shps As Shapes, shp As Shape
Dim i As Long

On Error GoTo Err_morning2013_10_8

ThisWorkbook.Sheets.Add before:=ThisWorkbook.Worksheets(1)
Set WS = ActiveSheet

Set shps = tgtWS.Shapes

On Error GoTo Non_Err_CK

i = 0
For Each shp In shps
i = i + 1
WS.Cells(i, 1).Value = shp.TextFrame.Characters.Caption
Next

On Error GoTo Err_morning2013_10_8

If i = 0 Then WS.Cells(1, 1).Value = "シェイプ情報を取得できませんでした。"

Set shp = Nothing
Set shps = Nothing
Set WS = Nothing

Exit Sub
Non_Err_CK:
Select Case Err.Number
Case 13
WS.Cells(i, 2).Value = shp.Name & " (" & TypeName(shp) & ")"
Resume Next
End Select

Err_morning2013_10_8:
Debug.Print Err.Number & " " & Err.Description
i = i - 1
Resume Next

End Sub
'------------------------------------------------------------------------------

【Excel/VBA】渡し値のブックに、ブック内リンク付きの目次をつける

※目次テンプレートを作っている前提
※目次をつけたいブックを開いた状態でCall

そういや、言ってなかったんですが、掲載ソースにインデントが無いのは、ブログに張り付けた時にぶっとんでしまったのを、スペースで置換するのがめんどくせーからです。

-----------------------------------------------
目次テンプレートの仕様（ソース準拠）
-----------------------------------------------
ファイル名 ＝目次.xlt
シート名＝目次
保存ディレクトリ＝エクセルのシステムディレクトリ（保存時、拡張子に.xltを選ぶと自動で移動する場所）
各シート名が並ぶ列の一列目の座標＝B2
クリックしたときに飛ぶセル＝C6
-----------------------------------------------
Public Sub Crt_Mokuji(WB As Workbook)
'=====================================================================
' 渡したワークブックに目次を付ける
'=====================================================================
Dim WS As Worksheet
Dim ShtNM() As String, i As Long
Dim tmpNM As String

Const TgtRang As String = "B2"

tmpNM = Application.TemplatesPath & "目次.xlt"
ReDim ShtNM(WB.Worksheets.Count - 1)

i = 0
For Each WS In WB.Worksheets
ShtNM(i) = WS.Name
i = i + 1
Next

WB.Sheets.Add Before:=WB.Worksheets(1), Type:=tmpNM
Set WS = WB.Worksheets("目次")

With WS

For i = 0 To UBound(ShtNM)
.Hyperlinks.Add .Range(TgtRang).Cells(1 + i, 1), "", "'" & ShtNM(i) & "'!C6", , ShtNM(i)
Next

End With

Set WS = Nothing

End Sub
-----------------------------------------------
イミディエイト
-----------------------------------------------
call crt_mokuji(workbooks("これに目次をつけたい.xls"))
-----------------------------------------------