'----------------------------------------------------- Public Sub DupShap(Str as String) '======================================== ' 選んだテキスト付シェイプを、渡したテキストの中身で書換えながら増殖 ' ' ※渡し値はカンマ区切りで頼む。 '======================================== Dim shps As ShapeRange Dim shp As Shape Dim wkAry() As String, i As Long
If TypeName(Selection) = "TextBox" Then
Set shps = Selection.ShapeRange ' シェイプの複数選択のエリア管理 Set shp = shps(1) ' こうしないとアクティブなシェイプを拾えないんだ…。 Set shps = Nothing
' コピー貼り付けしたシェイプを選んで、テキストを配列からセット Set shps = Selection.ShapeRange Set shp = shps(1) shp.TextFrame.Characters.Caption = wkAry(i)
Next
Set shp = Nothing Set shps = Nothing
End If
End Sub '----------------------------------------------------- ' イミディエイト '----------------------------------------------------- call DupShap("先導アイチ,櫂トシキ,葛木カムイ,戸倉ミサキ") '-----------------------------------------------------
'------------------------------------------------------------------------------------------------ Public Sub morning2013_9_25(Optional ByVal WS As Worksheet) Dim Max_Column As Long, wkWid As Double Dim i As Long Dim Rng As Range
If WS Is Nothing Then Set WS = ThisWorkbook.Worksheets(1)
'----------------------------------------------------------------------------- Public Sub morning2013_9_12(Workbook_Or_Worksheet As Variant) Dim wkTgt As Object, wkTgType As Byte, i() As Long
On Error GoTo Err_Get
wkTgType = 0
Select Case TypeName(Workbook_Or_Worksheet) Case "Workbook", "Worksheet"
ReDim i(1)
i(1) = 1 wkTgType = 2 Set wkTgt = Workbook_Or_Worksheet
If TypeName(Workbook_Or_Worksheet) = "Workbook" Then wkTgType = 1 i(1) = wkTgt.Worksheets.Count End If
Case Else
MsgBox "渡し値が無効です。ターゲットの判定ができません。処理は失敗しました。", , "【" & ThisWorkbook.Name & "】" Exit Sub
End Select
If wkTgType = 1 Then
For i(0) = 1 To i(1)
wkTgt.Worksheets(i(0)).Cells.Clear
Next
Else
wkTgt.Cells.Clear
End If
Set wkTgt = Nothing ReDim i(0)
Exit Sub Err_Get:
Debug.Print Err.Number & " " & Err.Description Resume Next
End Sub '-----------------------------------------------------------------------------