takayukisの日記

■[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

Permalink | コメント(0) | トラックバック(0) | 08:21

■[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 

Permalink | コメント(0) | トラックバック(0) | 08:18

■[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

Permalink | コメント(0) | トラックバック(0) | 08:15

■[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 

Permalink | コメント(0) | トラックバック(0) | 08:13

■[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

Permalink | コメント(0) | トラックバック(0) | 08:26

■[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

Permalink | コメント(0) | トラックバック(0) | 07:46

■[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

Permalink | コメント(0) | トラックバック(0) | 00:22

■[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

Permalink | コメント(0) | トラックバック(0) | 23:07