2018.10.23(火)
■[Excel]選択範囲の値で1つのシェイプを作る
複数列選択した場合、改行が入って縦に並びます。
Sub 選択範囲の値で1つのシェイプを作る() Dim シェイプ As Shape Dim 選択範囲 As Range Dim セル As Range Set 選択範囲 = Selection Dim 文字列 As String 文字列 = "" For Each セル In 選択範囲 If セル.Value <> "" Then If 文字列 = "" Then 文字列 = Trim(セル.Value) Else 文字列 = 文字列 & vbCrLf & Trim(セル.Value) End If End If Next Set シェイプ = ActiveSheet.shapes.AddShape(msoShapeRectangle, 選択範囲.Left, 選択範囲.Top, 80, 30) シェイプ.TextFrame.Characters.text = 文字列 シェイプ.TextFrame.AutoSize = True End Sub
■[Excel]図形のテキストを新しいワークブックのセルに出力
Sub オブジェクトのテキストを出力() Dim shapes Set shapes = ActiveSheet.shapes Dim b As Workbook Set b = Workbooks.Add Dim s As Worksheet Set s = b.Sheets(1) Dim row As Long row = 1 Dim shp As Shape For Each shp In shapes If shp.TextFrame2.TextRange.text <> "" Then 'Debug.Print shp.TextFrame2.TextRange.text s.Cells(row, 1).Value = Trim(shp.TextFrame2.TextRange.text) row = row + 1 End If Next End Sub
■[Excel]図形の横幅を揃える
Sub 横幅をそろえる() Dim シート As Worksheet Set シート = ActiveSheet Dim シェイプ As Variant Dim シェイプリスト As DrawingObjects Set シェイプリスト = Selection If シェイプリスト.count > 1 Then Dim 最大の横幅 As Double 最大の横幅 = 0 For Each シェイプ In シェイプリスト If 最大の横幅 < シェイプ.Width Then 最大の横幅 = シェイプ.Width End If Next For Each シェイプ In シェイプリスト シェイプ.Width = 最大の横幅 Next End If End Sub
追記
別バージョンがあった。
Sub 選択したオブジェクトの横幅を大きい方に合わせる() Dim 選択オブジェクト As ShapeRange Set 選択オブジェクト = Selection.ShapeRange Dim 最大値 As Long For Each オブジェクト In 選択オブジェクト If 最大値 < オブジェクト.Width Then 最大値 = オブジェクト.Width End If Next For Each オブジェクト In 選択オブジェクト オブジェクト.Width = 最大値 Next End Sub
■[Excel]選択範囲のテキストをシェイプにする
数年前のメモから。TextFrame2を使っているので、怪しい。
Sub 選択範囲のテキストをシェイプにする() Dim 選択セル As Range Set 選択セル = Selection Dim セル As Range Dim シェイプ As Shape For Each セル In 選択セル If セル.text <> "" Then Set シェイプ = シェイプ追加(セル) シェイプ.Select (False) End If Next セル End Sub Function シェイプ追加(セル As Range) As Shape Dim シート As Worksheet Set シート = ActiveSheet Dim シェイプ As Shape Set シェイプ = シート.Shapes.AddShape(msoShapeRectangle, 292.5, 134.25, 95.25, 73.5) Dim 選択セル As Range Set 選択セル = セル シェイプ.Top = 選択セル.Top シェイプ.Left = 選択セル.Left Dim テキストフレーム As TextFrame2 Set テキストフレーム = シェイプ.TextFrame2 テキストフレーム.WordWrap = msoFalse テキストフレーム.AutoSize = msoAutoSizeShapeToFitText テキストフレーム.TextRange.text = セル.text Set シェイプ追加 = シェイプ End Function
追記
別のバージョンがあった。
Sub 選択範囲の値でシェイプを作る() Dim シェイプ As Shape Dim 選択範囲 As Range Dim セル As Range Set 選択範囲 = Selection For Each セル In 選択範囲 Set シェイプ = ActiveSheet.shapes.AddShape(msoShapeRectangle, セル.Left, セル.Top, 80, 30) シェイプ.TextFrame.Characters.text = セル.Value シェイプ.TextFrame.AutoSize = True Next End Sub
2018.10.04(木)
■[Excel]選択範囲の1行ごとに行を挿入
Sub 選択範囲の1行ごとに行を挿入() Dim update As Boolean update = Application.ScreenUpdating Application.ScreenUpdating = False Dim text As String text = InputBox(prompt:="行数", Default:=1) Dim num As Long num = Val(text) If num <= 0 Then Exit Sub End If Dim 選択範囲 As Range Set 選択範囲 = Selection Dim r As Long r = 選択範囲.row For i = r + 選択範囲.Rows.Count To r + 1 Step -1 Debug.Print i Rows(i & ":" & (i + num - 1)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Next Application.ScreenUpdating = update End Sub
2018.06.28(木)
■[Excel]セルの値をテキストファイルに出力
長いテキストが入っている場合などに。
ファイル名はA1.txtなどのセルのアドレスになります。
Sub セルの値をテキストファイルに出力() Dim 選択範囲 As Range Set 選択範囲 = Selection For Each cell In 選択範囲 Dim セル As Range Set セル = cell Dim filename As String filename = セル.Address(RowAbsolute:=False, ColumnAbsolute:=False) & ".txt" Dim path As String path = ActiveWorkbook.path & "\" & filename Open path For Output As #1 Print #1, セル.Value Close #1 Next End Sub
2018.05.16(水)
■[Excel]固定長テキストをクリップボードからペースト
各列の桁数を1行(横長)に記載して、その範囲を選択している状態でマクロを実行します。
指定した桁数をオーバーする部分はすべて右端のセル(4列選択した場合は5列目)に入ります。
テキストファイルウィザードで固定長テキストを指定すると、初期状態で自動的に区切りを入れられて解除が非常に苦痛を伴うという余計な機能があったため作成。
Sub 固定長テキストをクリップボードからペースト() ' 選択範囲から定義情報を取得する Dim 選択範囲 As Range Set 選択範囲 = Selection If 選択範囲.Rows.Count > 1 Then Exit Sub End If Dim 横幅() As Integer Dim セル Dim i As Integer i = 0 ReDim 横幅(選択範囲.Columns.Count - 1) For Each セル In 選択範囲 横幅(i) = セル.Value i = i + 1 Next ' クリップボードからテキストを読み込む Dim cb As New DataObject cb.GetFromClipboard Dim text As String If cb.GetFormat(1) Then text = cb.GetText Else Exit Sub End If Dim lines() As String lines = Split(text, vbCrLf) Dim 挿入行数 As Long 挿入行数 = UBound(lines) + 1 Range((選択範囲.Row + 1) & ":" & (選択範囲.Row + 挿入行数)).Insert Dim str As String Dim 行番号 As Long For i = 0 To UBound(lines) 行番号 = 選択範囲.Row + 1 + i str = lines(i) Dim 長さ Dim 開始位置 As Integer 開始位置 = 0 Dim 列番号 As Long 列番号 = 選択範囲.Column Dim 文字列 As String For Each 長さ In 横幅 文字列 = Mid(str, 開始位置 + 1, 長さ) Cells(行番号, 列番号).Value = 文字列 開始位置 = 開始位置 + 長さ 列番号 = 列番号 + 1 Next 文字列 = Mid(str, 開始位置 + 1) Cells(行番号, 列番号).Value = 文字列 Next End Sub
2018.05.11(金)
■[Excel]VBA: 表を折り返す
データベースからコピーしたデータのような横に長い選択範囲を指定した列数になるように折り返します。
選択範囲の下に行を挿入して折り返される部分をコピーします(削除はしません)。
例。5列を指定した場合。◆などはセルを表します。
◆◆◆◆◆■■■■■ ◇◇◇◇◇□□□□□
↓
◆◆◆◆◆■■■■■ ◇◇◇◇◇□□□□□ ■■■■■ □□□□□
ソースコード
Sub 表を折り返す() Dim 選択範囲 As Range Set 選択範囲 = Selection Dim 行数 As Long 行数 = 選択範囲.Rows.Count Dim 列数 As Long 列数 = 選択範囲.Columns.Count Dim 最初の行番号 As Long 最初の行番号 = 選択範囲.row Dim 列番号 As Long 列番号 = 選択範囲.Column Dim 折り返しの列数str As String 折り返しの列数str = InputBox(prompt:="折り返しの列数") If 折り返しの列数str = "" Then Exit Sub End If Dim 折り返しの列数 As Long 折り返しの列数 = Val(折り返しの列数str) If 折り返しの列数 = 0 Then Exit Sub End If Dim 折り返し回数 As Long 折り返し回数 = 列数 / 折り返しの列数 Dim 余り As Long 余り = 列数 Mod 折り返しの列数 If 余り <> 0 Then 折り返し回数 = 折り返し回数 + 1 End If Dim 挿入行数 As Long 挿入行数 = (折り返し回数 - 1) * 行数 Dim 挿入開始行番号 As Long 挿入開始行番号 = 最初の行番号 + 行数 Dim 挿入終了行番号 As Long 挿入終了行番号 = 挿入開始行番号 + 挿入行数 - 1 Range(挿入開始行番号 & ":" & 挿入終了行番号).Insert 'コピー Dim r As Long Dim c As Long Dim r2 As Long Dim c2 As Long Dim srcR As Long Dim srcC As Long Dim dstR As Long Dim dstC As Long Dim シート As Worksheet Set シート = ActiveSheet For c = 折り返しの列数 To 列数 - 1 For r = 0 To 行数 - 1 c2 = c Mod 折り返しの列数 r2 = r + Int(c / 折り返しの列数) * 行数 srcC = 列番号 + c srcR = 最初の行番号 + r dstC = 列番号 + c2 dstR = 最初の行番号 + r2 'Debug.Print c&; "," & r & " -> " & c2&; "," & r2 & " " & _ ' srcC&; "," & srcR & " -> " & dstC&; "," & dstR & " " & _ ' シート.Range(Cells(srcR, srcC), Cells(srcR, srcC)).Value & _ ' シート.Range(Cells(dstR, dstC), Cells(dstR, dstC)).Value シート.Range(Cells(dstR, dstC), Cells(dstR, dstC)).Value = シート.Range(Cells(srcR, srcC), Cells(srcR, srcC)).Value Next Next End Sub