------------------------------------------------------------- Private Function Chg_Fid_Str(Str As Variant) As String '============================================ ' 読点と改行をカンマに変換する '============================================ Dim wkAry() As String, i As Long, wkStr As String
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 -------------------------------------------------------------
'----------------------------------------------------------------------------------------- Public Sub Replace_RaS(Tgt_Text As String, Rep_Text As String, Optional Mode As Long) '==================================== ' 選んだワークシートの全置換※シェイプ内テキストを含む '==================================== Dim WSs As Object, WS As Worksheet Dim Rng As Range Dim shps As Shapes, shp As Shape Dim i As Long, wkStr As String
On Error GoTo Err_Replace_RaS
i = 0 If Mode = 0 Then Mode = xlFormulas
Set WSs = ActiveWindow.SelectedSheets Application.ScreenUpdating = False
For Each WS In WSs
' 普通に置換 Set Rng = WS.Cells.Find(Tgt_Text, , Mode) Do Until Rng Is Nothing Select Case Mode Case xlFormulas Rng.Formula = Replace(Rng.Formula, Tgt_Text, Rep_Text) Case xlValues Rng.Value = Replace(Rng.Value, Tgt_Text, Rep_Text) Case xlComments Rng.Comment = Replace(Rng.Comment, Tgt_Text, Rep_Text) Case Else Rng.Value = Replace(Rng.Value, Tgt_Text, Rep_Text) End Select
i = i + 1 Set Rng = WS.Cells.Find(Tgt_Text, Rng, Mode) Loop
Set Rng = Nothing Set shps = WS.Shapes
On Error GoTo Non_Err_CK
For Each shp In shps If InStr(shp.TextFrame.Characters.Caption, Tgt_Text) > 0 Then wkStr = shp.TextFrame.Characters.Caption shp.TextFrame.Characters.Caption = Replace(wkStr, Tgt_Text, Rep_Text) i = i + 1 End If Skip_Shp: Next
Set shp = Nothing Set shps = Nothing
On Error GoTo Err_Replace_RaS Next
Application.ScreenUpdating = True
MsgBox i & " 件置換しました。"
Exit Sub Non_Err_CK: Select Case Err.Number Case 13 Resume Skip_Shp End Select
Err_Replace_RaS: Debug.Print Err.Number & " " & Err.Description Resume Next End Sub '-----------------------------------------------------------------------------------------
余談で発見したTips。Variant型のOptionalが省略されている時に、規定値を設定したい時 （↑の『If Mode = 0 Then Mode = xlFormulas』のModeがLong型じゃなくてVariant型だったら）
'------------------------------------------------------------------------------ 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 '------------------------------------------------------------------------------
----------------------------------------------- 目次テンプレートの仕様（ソース準拠） ----------------------------------------------- ファイル名 ＝目次.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
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")) -----------------------------------------------
