記載予定

Sub ReIndentFormModule()

    Dim vbComp As VBComponent

    Dim codeMod As CodeModule

    Dim codeLines As String

    Dim lineNum As Long

    Dim formattedCode As String

    

    ' 対象のフォームモジュールを設定（例: "UserForm1"）

    Set vbComp = ThisWorkbook.VBProject.VBComponents("UserForm1")

    Set codeMod = vbComp.CodeModule

    

    ' フォームのコード部分を取得

    codeLines = ""

    For lineNum = 1 To codeMod.CountOfLines

        codeLines = codeLines & codeMod.Lines(lineNum, 1) & vbCrLf

    Next lineNum

    

    ' 再インデント処理（例: 各行の先頭にスペースを追加）

    ' ※実際の再インデントロジックは必要に応じて変更してください

    formattedCode = ReIndentCode(codeLines)

    

    ' フォームのコード部分を上書き（デザイン情報は保持される）

    codeMod.DeleteLines 1, codeMod.CountOfLines ' 既存のコードを削除

    codeMod.AddFromString formattedCode ' 整形済みコードを追加

End Sub

 

' 再インデントのロジック（簡単な例としてスペースを追加）

Function ReIndentCode(ByVal code As String) As String

    Dim codeLines() As String

    Dim line As String

    Dim formattedLines As String

    Dim i As Long

    

    ' コードを行ごとに分割

    codeLines = Split(code, vbCrLf)

    formattedLines = ""

    

    ' 各行にインデントを追加

    For i = LBound(codeLines) To UBound(codeLines)

        line = codeLines(i)

        formattedLines = formattedLines & "    " & line & vbCrLf ' スペース4つのインデント

    Next i

    

    ReIndentCode = formattedLines

End Function

Sub 図形内の文字を取得()

    Dim shp As Shape

    Dim strText As String

 

    For Each shp In ActiveSheet.Shapes

        strText = shp.TextFrame.Characters.Text

        MsgBox shp.Name & "   " & strText

    Next shp

End Sub

Sub RenameDuplicateShapes()

    Dim shapeDict As Object

    Set shapeDict = CreateObject("Scripting.Dictionary")

    

    Dim ws As Worksheet

    Dim shp As Shape

    Dim originalName As String

    Dim newName As String

    Dim counter As Long

    

    ' アクティブシートを取得（必要に応じて特定のシートを指定してください）

    Set ws = ActiveSheet

    

    ' シート内のすべての図形に対して処理

    For Each shp In ws.Shapes

        originalName = shp.Name

        

        ' 既に存在する図形名である場合、名称を変更

        If shapeDict.Exists(originalName) Then

            counter = shapeDict(originalName) + 1

            newName = originalName & "_" & counter

            

            ' 新しい名前が既に存在するか確認し、存在する場合はさらにインクリメント

            Do While shapeDict.Exists(newName)

                counter = counter + 1

                newName = originalName & "_" & counter

            Loop

            

            ' 図形の名前を変更し、辞書に追加

            shp.Name = newName

            shapeDict.Add newName, 1

            shapeDict(originalName) = counter

        Else

            ' 新しい図形名として辞書に登録

            shapeDict.Add originalName, 1

        End If

    Next shp

    

    MsgBox "重複する図形名を修正しました。", vbInformation

End Sub

Option Explicit

 

Public WithEvents wb As Workbook          'この　wbはAppEventClass の　Set AppEvws1.wb = wb　に対応

                                                              'この名前を合わせないと上記の文がエラーになる

'　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　’AppEvWs(このクラスモジュール名) ⇒　AppEvws1（そのインスタンス名）⇒をこで使われるWorkbook名(wb)と定義

'　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　’クラスモジュール間で引数をやり取りする方法

Private Sub Wb_SheetActivate(ByVal Sh As Object)      'App イベントのひとつ（シートチェンジ）

    ' フォームのShowFormメソッドを呼び出して、シート名を表示

    MsgBox wb.Name & " / " & Sh.Name

End Sub

 

'まとめ

'①

'    workbookopenかform Initiarize　で　Appイベントの使用を宣言

    'Private Sub Workbook_Open()

    '    ' Applicationオブジェクトのイベントを有効化

    '    ' VBAが異常終了するとこの文は無効になるのでできたら他で（フォームの立ち上げとか）で宣言した方が好ましい

    '    Application.EnableEvents = True

    '    ' WorkbookActivateイベントを監視するためにイベントを有効化

    '    Set AppEvHandl = New AppEventClass     'Setの次の項目は標準モジュールで　Public AppEvHandl As New AppEventClass　のように定義する

    '                                                                  'New　の次の項目はこのイベントを扱うクラスモジュール名

    '

    'End Sub

'②標準モジュール先頭に　 クラスモジュールのインスタンスを作成

'    Public AppEvHandl As New AppEventClass

'③ActiveWorkbookが変わった時のクラスモジュール　ここではAppEventClassを作成する

    '  その内容

    'Public WithEvents App As Application      '定型文

    'Private AppEvws1 As AppEvWs              '左辺AppEvWsのインスタンス名　右辺はシートチェンジを扱うクラスモジュール名

    '

    'Private Sub Class_Initialize()

    '    Set App = Application                '定型文

    'End Sub

    'Private Sub App_WorkbookActivate(ByVal wb As Workbook)        'Appイベントのひとつ　ActiveWorkbookが替わったときにイベントが発生する

    ' If wb.Name <> ThisWorkbook.Name Then                                    'この場合アプリの仕様上自身のワークブック選択時は除外している

    '        Set AppEvws1 = New AppEvWs                                              '左辺AppEvWs　のインスタンス'

    '        Set AppEvws1.wb = wb                                                        'AppEvWsの中で使われるworkbook名を代入(wbはこのプロシージャの ws As Workbookで引数として

    '                                                                                                  'App　から受け取っている

    '        Dim activeSheetName As String

    '        activeSheetName = wb.ActiveSheet.Name                              'wbのActiveSheet名　このくだりを書かないとActiveBookが替わった時のそのシート名を取得できない

    '         MsgBox wb.Name & " / " & ActiveSheet.Name

    ' End If

    ''End Sub

'④シートチェンジしたときのイベントをとらえるクラスモジュール　AppEvWs を作成する

'　　上記文

 

 Option Explicit

 Public IsUpdatingListBox As Boolean

Private Sub ListBox1_Click()

    If Not IsUpdatingListBox Then

        With ListBox1

            TextBox1 = .List(.ListIndex, 0)

            TextBox2 = .List(.ListIndex, 1)

        End With

    End If

End Sub

 

Private Sub CommandButton2_Click()

    IsUpdatingListBox = True ' フラグを立てる

    With ListBox1

        .List(.ListIndex, 0) = TextBox1

        .List(.ListIndex, 1) = TextBox2

    End With

    IsUpdatingListBox = False ' フラグを戻す

End Sub

 

Sub B010_02B()

    Dim dic1 As Object

    Set dic1 = CreateObject("Scripting.dic1ionary")

    Dim i As Long

 

    ' クラスモジュールをインスタンス化 (クラスモジュール名は適宜変更)

    Dim objCustomer As Customer

 

    ' 取引先データを連想配列に格納

        For i = 2 To 6

            Set objCustomer = New Customer

            With objCustomer

                .取引先名 = Cells(i, "K").Value

                .取引先郵便番号 = Cells(i, "L").Value

                .取引先住所 = Cells(i, "M").Value

            End With

            dic1.Add Key:=Cells(i, "J").Value, Item:=objCustomer

        Next i

          

        For i = 2 To 4

            If dic1.Exists(Cells(i, "B").Value) Then

                With dic1(Cells(i, "B").Value)

                    Cells(i, "C").Value = .取引先名

                    Cells(i, "D").Value = .取引先郵便番号

                    Cells(i, "E").Value = .取引先住所

                End With

            End If

        Next i

    

End Sub

 

 

Private p_取引先名 As String

Private p_取引先郵便番号 As String

Private p_取引先住所 As String

'オブジェクトのプロパティに値を代入するときに使用します｡

Public Property Let 取引先名(ByVal Value As String)

    p_取引先名 = Value

End Property

'オブジェクトのプロパティの値を取得するときに使用します 呼ばれるとクラスオブジェクト内の該当項目を返す

Public Property Get 取引先名() As String

    取引先名 = p_取引先名

End Property

Public Property Let 取引先郵便番号(ByVal Value As String)

    p_取引先郵便番号 = Value

End Property

Public Property Get 取引先郵便番号() As String

    取引先郵便番号 = p_取引先郵便番号

End Property

Public Property Let 取引先住所(ByVal Value As String)

    p_取引先住所 = Value

End Property

Public Property Get 取引先住所() As String

    取引先住所 = p_取引先住所

End Property

 

Sub B010_02C()

    Dim dic1 As Object

    Dim 取引先名 As String

    Dim 取引先郵便番号 As String

    Dim 取引先住所 As String

    Dim i As Long

    Set dic1 = CreateObject("Scripting.dictionary")

 

    ' クラスモジュールをインスタンス化 (クラスモジュール名は適宜変更)

    Dim cust As Custom2A

'     取引先データを連想配列に格納

    For i = 2 To 6

            取引先名 = Cells(i, "K").Value

            取引先郵便番号 = Cells(i, "L").Value

            取引先住所 = Cells(i, "M").Value

        

            Set cust = New Custom2A

            cust.p_取引先名2 = 取引先名

            cust.p_取引先郵便番号2 = 取引先郵便番号

            cust.p_取引先住所2 = 取引先住所

            dic1.Add Key:=Cells(i, "J").Value, Item:=cust

        Next i

          

        For i = 2 To 4

            If dic1.Exists(Cells(i, "B").Value) Then

                Set cust = dic1(Cells(i, "B").Value)

                Cells(i, "C").Value = cust.p_取引先名2

                Cells(i, "D").Value = cust.p_取引先郵便番号2

                Cells(i, "E").Value = cust.p_取引先住所2

            End If

        Next i    

End Sub

Option Explicit

 

Public p_取引先名2 As String

Public p_取引先郵便番号2 As String

Public p_取引先住所2 As String

' ProcedureInfoクラスモジュール
Public Name As String
Public StartLine As Long
Public EndLine As Long
Public Calls As Collection
 
Private Sub Class_Initialize()
    Set Calls = New Collection
End Sub
 
 
 
ub AnalyzeProcedures()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim procDict As Object
    Dim i As Long, j As Long
    Dim procName As String, startLine As Long, endLine As Long
    Dim procInfo As ProcedureInfo
 
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    Set ws3 = ThisWorkbook.Sheets("Sheet3")
    Set procDict = CreateObject("Scripting.Dictionary")
 
    ' Sheet2からプロシージャ情報を読み込む
    For i = 2 To ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
        procName = ws2.Cells(i, 1).Value
        startLine = ws2.Cells(i, 2).Value
        endLine = ws2.Cells(i, 3).Value
 
        Set procInfo = New ProcedureInfo
        procInfo.Name = procName
        procInfo.StartLine = startLine
        procInfo.EndLine = endLine
 
        procDict.Add procName, procInfo
    Next i
 
    ' プロシージャの呼び出し関係を解析
    For Each procName In procDict.Keys
        Set procInfo = procDict(procName)
        For j = procInfo.StartLine To procInfo.EndLine
            If InStr(ws1.Cells(j, 1).Value, "Call ") > 0 Then
                Dim calledProc As String
                calledProc = Trim(Split(ws1.Cells(j, 1).Value, "Call ")(1))
                If procDict.Exists(calledProc) Then
                    procInfo.Calls.Add procDict(calledProc)
                End If
            End If
        Next j
    Next procName
 
    ' ネスト構造をSheet3に出力
    ws3.Cells.Clear
    Dim row As Long
    row = 1
    For Each procName In procDict.Keys
        Set procInfo = procDict(procName)
        Call WriteProcedure ws3, procInfo, row, 0
    Next procName
End Sub
 
Sub WriteProcedure(ws As Worksheet, procInfo As ProcedureInfo, ByRef row As Long, indent As Long)
    ws.Cells(row, 1).Value = String(indent * 2, " ") & procInfo.Name
    row = row + 1
    Dim calledProc As ProcedureInfo
    For Each calledProc In procInfo.Calls
        Call WriteProcedure(ws, calledProc, row, indent + 1)
    Next calledProc
End Sub

' OneDriveフォルダのFileSystemObjectを取得

Set fso = CreateObject("Scripting.FileSystemObject")

 

' ファイルの存在を確認

strFilePath = fso.GetSpecialFolder(SHFOLDER_LOCAL_APPDATA) & "\Microsoft\OneDrive\test.xlsx"

If Not fso.FileExists(strFilePath) Then

    ' ファイルが存在しない

    MsgBox "ファイルが存在しません。"

Else

    ' ファイルが存在する

    ' ファイルの属性情報を確認

    Set fsoFile = fso.GetFile(strFilePath)

    If fsoFile.Attributes And vbReadOnly Then

        ' ファイルが開けない

        MsgBox "ファイルが開けません。(アクセス権不足)"

    Else

        ' ファイルを開ける

        Workbooks.Open strFilePath

    End If

End If

Sub ABC3()

'B,C,D,E で合成キーを作成　但し、Ｃ2桁　Ｄ2桁　E　1桁とする

Dim i, L1, L2, LMax As Long

'文字列の最大列数を求める

For i = 2 To 5

L1 = Len(Cells(i, "B"))

If LMax < L1 Then LMax = L1

Next

For i = 2 To 5

L2 = Len(Cells(i, "B"))

Cells(i, "G") = Cells(i, "B") & String(LMax - L2 + 1, " ") & Right("00" & Cells(i, "C"), 2) & _

" " & Right("00" & Cells(i, "D"), 2) & " " & Right("0" & Cells(i, "E"), 1)

Next

Range("G:G").Font.Name = "Consolas"

End Sub

 

 

Sub atest2()

Dim sizea As Long

Dim fonta As String

Dim chlen As Long

Dim slflg As Boolean

Dim cnam As Variant

Dim color1 As Variant

Dim maru As Double

ActiveSheet.Shapes.Range(Array("四角形: 角を丸くする 1")).Select

cnam = Selection.ShapeRange.TextFrame.Characters.Text   'コピー元の文字を取得

chlen = Len(cnam)

With Selection.ShapeRange.TextFrame2.TextRange

    sizea = .Font.Size    'コピー元のフォントサイズを取得

    fonta = .Font.Name       'コピー元のフォント名を取得

End With

With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 1).Font

    slflg = .Bold    'コピー元が太字かどうか取得

    color1 = .Fill.ForeColor.RGB    'コピー元の色を取得

 End With

 If Selection.Name Like "*四角形: 角を丸くする*" Or Selection.Name Like "*Rounded Rectangle*" Then

   maru = Selection.ShapeRange.Adjustments.Item(1)

 End If

 

ActiveSheet.Shapes.Range(Array("四角形: 角を丸くする 2")).Select        'コピー先文字のプロパディを設定

If Selection.Name Like "*四角形: 角を丸くする*" Or Selection.Name Like "*Rounded Rectangle*" Then

Selection.ShapeRange.Adjustments.Item(1) = maru  '角の丸さを設定

End If

 

Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = cnam     'コピー元の文字を貼り付け

Selection.ShapeRange.TextFrame2.TextRange.Font.Size = sizea                     'コピー元のフォントサイズを適用

With Selection.ShapeRange.TextFrame2.TextRange.Font                'コピー元のフォント名を適用

    .NameComplexScript = fonta

    .NameFarEast = fonta

    .Name = fonta

End With

    

With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, chlen).Font     'コピー先文字のプロパディを適用

    .Fill.Visible = msoTrue

    .Fill.ForeColor.RGB = color1    'コピー先文字の色を適用

    If slflg = True Then .Bold = msoTrue       'コピー先文字の太さを適用

End With

End Sub

範囲内の図形選択

Sub Getshape1()

Dim i As Long

Dim shp As Shape

Dim Range1 As Range

Dim Range2 As Range

Dim ary1()

Set Range1 = Selection

For Each shp In Range1.Worksheet.Shapes

    Set Range2 = Range(shp.topleftcell, shp.bottomRightCell)

    If Not Intersect(Range2, Range1) Is Nothing Then

        If Intersect(Range2, Range1).Address = Range2.Address Then

            i = i + 1

            ReDim Preserve ary1(i)

            ary1(i) = shp.Name

        End If

    End If

Next

ActiveSheet.Shapes.Range(ary1).Select

 

End SubSub Getshape1()

Dim i As Long

Dim shp As Shape

Dim Range1 As Range

Dim Range2 As Range

Dim ary1()

Set Range1 = Selection

For Each shp In Range1.Worksheet.Shapes

    Set Range2 = Range(shp.topleftcell, shp.bottomRightCell)

    If Not Intersect(Range2, Range1) Is Nothing Then

        If Intersect(Range2, Range1).Address = Range2.Address Then

            i = i + 1

            ReDim Preserve ary1(i)

            ary1(i) = shp.Name

        End If

    End If

Next

ActiveSheet.Shapes.Range(ary1).Select

End Sub

Sub 図形名分割2(図形名 As Variant)   'name3とnama2はpublic定義の必要あり　図形内文字分割

Dim ar5()

Dim i, leng1, leng2 As Long

Dim 結果

Dim s_flg As Long

 

leng1 = Len(図形名)

'図形名を1文字ずつ分解する

For i = 1 To leng1

ReDim Preserve ar5(2, i)

'1行目に図形名　2行目に文字数字区分（数字　0　文字　1）

ar5(1, i) = Mid(図形名, i, 1)

If IsNumeric(ar5(1, i)) Then

ar5(2, i) = 0

Else

ar5(2, i) = 1

End If

Next

 

leng2 = 0    'leng2 は文字数の数

For i = 1 To leng1

leng2 = leng2 + 1

If ar5(2, i) = 0 Then Exit For

Next

If leng2 <> leng1 Then

name2 = Left(図形名, leng2 - 1)

Else

name2 = 図形名

End If

 

MsgBox name2 & " GG"

name3 = Right(図形名, leng1 - leng2 + 1)

 

 

End Sub

Private Sub 図形連番コピー_Click()

Dim ar3()

Dim i, k As Long

Dim digit1, digit2, digit3 As Long 'digit1 元の図形内数字の桁数、digit2演算後の桁数

Dim ar5()

Dim shp As Shape

Dim shp_n As String

Dim moji1 As String

Dim top1, top2, left1, height1, intaval1 As Double

 

Dim count, name2v As Long

intaval1 = 20

 Dim ゼロ詰め後 As String

count = InputBox("コピー回数")

 

On Error Resume Next

If VarType(Selection) = vbObject Then

    Else

       MsgBox "図形は選択されていせん。"

    Exit Sub

  End If

For Each shp In Selection.ShapeRange '実際は一回しかループしない

shp_n = shp.Name

top1 = shp.Top

left1 = shp.Left

height1 = shp.Height

Next

name2v = Val(name2)

ReDim ar5(count)

moji1 = ActiveSheet.Shapes(shp_n).TextFrame.Characters.Text  'テキスト内文字取得

Call 図形名分割2(moji1)      '文字を　分割　name2 テキスト内文字列　文字部分　name3  テキスト内文字列　数字部分

digit1 = Len(name3)

k = Val(name3)

For i = 1 To Val(count)

If k <> 0 Then

k = k + 1

'最初の桁数に連番が収まるようにする処理

digit2 = Len(CStr(k))

digit3 = digit1 - digit2

    ' 条件によって桁数を制御

    If digit3 = 3 Then

        ゼロ詰め後 = "000" & k

    ElseIf digit3 = 2 Then

        ゼロ詰め後 = "00" & k

    ElseIf digit3 = 1 Then

        ゼロ詰め後 = "0" & k

    Else

        ゼロ詰め後 = CStr(k) '

    End If

ar5(i) = name2 & ゼロ詰め後   '編集後テキスト内文字

Else

ar5(i) = name2

End If

Next

Range("c5:e15") = ar5

'実際の図形のコピー処理

For i = 1 To Val(count)

 

 ActiveSheet.Shapes.Range(Array(shp_n)).Select

    Selection.Copy

    ActiveSheet.Paste

    '図形内文字列の編集

    Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = ar5(i)

    Selection.Left = left1

    top2 = top1 + ((intaval1 + height1) * i)

    Selection.Top = top2

    DoEvents

Next

 

End Sub

Sub バブルソート(ByRef argAry() As Variant, ByVal keyPos As Long)

    Dim vSwap

    Dim i As Integer

    Dim j As Integer

    Dim k As Integer

    For i = LBound(argAry, 1) To UBound(argAry, 1)

        For j = LBound(argAry) To UBound(argAry) - 1

            If argAry(j, keyPos) > argAry(j + 1, keyPos) Then

                For k = LBound(argAry, 2) To UBound(argAry, 2)

                    vSwap = argAry(j, k)

                    argAry(j, k) = argAry(j + 1, k)

                    argAry(j + 1, k) = vSwap

                Next

            End If

        Next j

    Next i

 

End Sub

Sub 罫線シフト()

 Dim kb As Long

 Dim flg1 As String

 Dim i, sen1, sen2, wht1, wht2 As Long

 Dim strow, edrow, CurrentRow, stcol As Long

 Dim targetcell As Range

 Dim target, topleftcell As Range

 Dim kb2 As Object

 Set target = Selection

 If Not target Is Nothing Then  '何かしたセルが選択されているとき

    Set topleftcell = target.Cells(1, 1)   ' 左上のセルを取得

    stcol = topleftcell.Column      ' 左上のセルの列

    strow = topleftcell.Row          '左上のセルの行

 

    edrow = topleftcell.SpecialCells(xlCellTypeLastCell).Row    'その列の最大行（文字なしを含む）

    Set targetcell = topleftcell        'targetcellはoffsetで変動させる

    If targetcell.Borders(xlEdgeRight).LineStyle <> xlNone Then

        flg1 = "R"

    Else

        If targetcell.Borders(xlEdgeLeft).LineStyle <> xlNone Then

            flg1 = "L"

        End If

    End If

    If flg1 = "" Then Exit Sub

    sen1 = targetcell.Borders(xlEdgeLeft).LineStyle      '計算のプロパティを取得

    sen2 = targetcell.Borders(xlEdgeRight).LineStyle

    wht1 = targetcell.Borders(xlEdgeLeft).Weight

    wht2 = targetcell.Borders(xlEdgeRight).Weight

    

    CurrentRow = strow

    For i = strow To edrow      '1セルずつ下にたどり罫線の続いている最下行を求める

      Set targetcell = targetcell.Offset(1, 0)

      If flg1 = "L" Then

          If targetcell.Borders(xlEdgeLeft).LineStyle <> xlNone Then

             CurrentRow = CurrentRow + 1

          Else

            Exit For

          End If

      End If

      If flg1 = "R" Then

         If targetcell.Borders(xlEdgeRight).LineStyle <> xlNone Then

             CurrentRow = CurrentRow + 1

          Else

             Exit For

          End If

      End If

      If flg1 = "" Then Exit For

    Next

Else

    MsgBox "セルが選択されていません。"

    Exit Sub

End If

kb = 2    '右シフトを選択　　ｋｂ=1　なら左シフト

Range(Cells(strow, stcol), Cells(CurrentRow, stcol)).Select

If flg1 = "L" Then Selection.Borders(xlEdgeLeft).LineStyle = xlNone      '罫線削除

If flg1 = "R" Then Selection.Borders(xlEdgeRight).LineStyle = xlNone

If kb = 1 Then      '左シフトの場合

    Range(Cells(strow, stcol - 1), Cells(CurrentRow, stcol - 1)).Select

    If flg1 = "L" Then Selection.Borders(xlEdgeLeft).LineStyle = sen1

     If flg1 = "L" Then Selection.Borders(xlEdgeLeft).Weight = wht1

    If flg1 = "R" Then Selection.Borders(xlEdgeRight).LineStyle = sen2

     If flg1 = "R" Then Selection.Borders(xlEdgeRight).Weight = wht2 '

Else          '右シフトの場合

   Range(Cells(strow, stcol + 1), Cells(CurrentRow, stcol + 1)).Select

   If flg1 = "L" Then Selection.Borders(xlEdgeLeft).LineStyle = sen1

    If flg1 = "L" Then Selection.Borders(xlEdgeLeft).Weight = wht1

   If flg1 = "R" Then Selection.Borders(xlEdgeRight).LineStyle = sen2

    If flg1 = "R" Then Selection.Borders(xlEdgeRight).Weight = wht2

End If

End Sub

 

Sub 図形名分割(図形名 As Variant)　　'name3とnama2はpublic定義の必要あり

Dim ar5()

Dim i, leng1, leng2 As Long

Dim 結果

leng1 = Len(図形名)

Dim name1

For i = 1 To leng1

ReDim Preserve ar5(2, i)

ar5(1, i) = Mid(図形名, i, 1)

If IsNumeric(ar5(1, i)) Then

ar5(2, i) = 0

Else

ar5(2, i) = 1

End If

Next

 

leng2 = 0

For i = 1 To leng1

leng2 = leng2 + 1

If ar5(2, i) = 0 Then Exit For

Next

name1 = Left(図形名, leng2 - 2)

name2 = Right(図形名, leng1 - leng2 + 1)

name3 = dic_x(name1)

name3 = name3 & " " & name2

End Sub

 

Sub 配列作成()    '英文図形名を和文に変換する連想配列を作成する

Dim 図形名本体 As String, 図形名連番 As String

Dim ar11, ar12

Dim i As Long

'Dim dic_x As Object    'dic_x はグローバルまたはpublic変数として登録しておく

Set dic_x = CreateObject("scripting.dictionary")

 

ar11 = Array("Straight Connector", "Straight Arrow Connector", "Elbow Connector", "Curved Connector", "Freeform", _

"Rectangle", "Rounded Rectangle", "Snip Single Corner Rectangle", "Snip Same Side Corner Rectangle", "Snip Diagonal Corner Rectangle", _

"Snip and Round Single Corner Rectangle", "Round Single Corner Rectangle", "Round Same Side Corner Rectangle", _

"Round Diagonal Corner Rectangle", "TextBox", "Oval", "Isosceles Triangle", "Right Triangle", "Parallelogram", "Trapezoid ", "Diamond", _

"Regular Pentagon", "Hexagon", "Heptagon", "Octagon", "Decagon", "Dodecagon", "Pie", "Chord", "Teardrop", "Frame", "Half Frame", _

"L-Shape", "Diagonal Stripe", "Cross", "Plaque", "Can", "Cube", "Bevel", "Donut", "No Symbol", "Block Arc", "Folded Corner", "Smiley Face", _

"Heart", "Lightning Bolt", "Sun", "Moon", "Cloud", "Arc", "Double Bracket", "Double Brace", "Left Bracket", "Right Bracket", "Left Brace", _

"Right Brace", "Right Arrow", "Left Arrow", "Up Arrow", "Down Arrow", "Left-Right Arrow", "Up-Down Arrow", "Quad Arrow", _

"Left-Right-Up Arrow", "Bent Arrow", "U-Turn Arrow", "Left-Up Arrow", "Bent-Up Arrow", "Curved Right Arrow", "Curved Left Arrow", _

"Curved Up Arrow", "Curved Down Arrow", "Striped Right Arrow", "Notched Right Arrow", "Pentagon", "Chevron", "Right Arrow Callout", _

"Down Arrow Callout", "Left Arrow Callout", "Up Arrow Callout", "Left-Right Arrow Callout", "Quad Arrow Callout", "Circular Arrow", "Plus", "Minus", _

"Multiply", "Division", "Equal", "Not Equal", "Flowchart: Process", _

"Flowchart: Alternate Process", "Flowchart: Decision", "Flowchart: Data", "Flowchart: Predefined Process", "Flowchart: Internal Storage", _

"Flowchart: Document", "Flowchart: Multidocument", "Flowchart: Terminator", "Flowchart: Preparation", "Flowchart: Manual Input", _

"Flowchart: Manual Operation", "Flowchart: Connector", "Flowchart: Off-page Connector", "Flowchart: Card", "Flowchart: Punched Tape", _

"Flowchart: Summing Junction", "Flowchart: Or", "Flowchart: Collate", "Flowchart: Sort", "Flowchart: Extract", _

"Flowchart: Merge", "Flowchart: Stored Data", "Flowchart: Delay", "Flowchart: Sequential Access Storage", "Flowchart: Magnetic Disk", _

"Flowchart: Direct Access Storage", "Flowchart: Display", "Explosion 1", "Explosion 2", "4-Point Star", _

"5-Point Star", "6-Point Star", "7-Point Star", "8-Point Star", "10-Point Star", "12-Point Star", "16-Point Star", "24-Point Star", _

"32-Point Star", "Up Ribbon", "Down Ribbon", "Curved Up Ribbon", "Curved Down Ribbon", "Vertical Scroll", "Horizontal Scroll", _

"Wave", "Double Wave", "Double Wave", "Rounded Rectangular Callout", "Oval Callout", "Cloud Callout", "Line Callout 1", _

"Line Callout 2", "Line Callout 3", "Line Callout 1 (Accent Bar)", "Line Callout 2 (Accent Bar)", "Line Callout 3 (Accent Bar)", _

"Line Callout 1 (No Border)", "Line Callout 2 (No Border)", "Line Callout 3 (No Border)", "Line Callout 1 (Border and Accent Bar)", _

"Line Callout 2 (Border and Accent Bar)", "Line Callout 3 (Border and Accent Bar)", "Group")

 

ar12 = Array("直線コネクタ", "直線矢印コネクタ", "コネクタ: カギ線", "コネクタ: 曲線", "フリーフォーム: 図形", _

 "正方形/長方形", "四角形: 角を丸くする", "四角形: 1 つの角を切り取る", "四角形: 上の 2 つの角を切り取る", "四角形: 対角を切り取る", _

 "四角形: 1 つの角を切り取り 1 つの角を丸める", "四角形: 1 つの角を丸める", "四角形: 上の 2 つの角を丸める", "四角形: 対角を丸める", "テキスト ボックス", _

"楕円", "二等辺三角形", "直角三角形", "平行四辺形", "台形", _

"ひし形", "五角形", "六角形", "七角形", "八角形", "十角形", "十二角形", "部分円", "弦", "涙形", _

"フレーム", "フレーム (半分)", "L 字", "斜め縞", "十字形", "ブローチ", "円柱", "直方体", "四角形: 角度付き", "円: 塗りつぶしなし", _

"禁止マーク", "アーチ", "四角形: メモ", "スマイル", "ハート", "稲妻", "太陽", "月", "雲", "円弧", _

"大かっこ", "中かっこ", "左大かっこ", "右大かっこ", "左中かっこ", "右中かっこ", "矢印: 右", "矢印: 左", "矢印: 上", "矢印: 下", _

"矢印: 左右", "矢印: 上下", "矢印: 四方向", "矢印: 三方向", "矢印: 折線", "矢印: U ターン", "矢印: 二方向", "矢印: 上向き折線", "矢印: 右カーブ", "矢印: 左カーブ", _

"矢印: 上カーブ", "矢印: 下カーブ", "矢印: ストライプ", "矢印: V 字型", "矢印: 五方向", "矢印: 山形", "吹き出し: 右矢印", "吹き出し: 下矢印", "吹き出し: 左矢印", "吹き出し: 上矢印", _

"吹き出し: 左右矢印", "吹き出し: 四方向矢印", "矢印: 環状", "加算記号", "減算記号", "乗算記号", "除算記号", "次の値と等しい", "等号否定", "フローチャート: 処理", _

"フローチャート: 代替処理", "フローチャート: 判断", "フローチャート: データ", "フローチャート: 定義済み処理", "フローチャート: 内部記憶", "フローチャート: 書類", "フローチャート: 複数書類", "フローチャート: 端子", "フローチャート: 準備", "フローチャート: 手操作入力", _

"フローチャート: 手作業", "フローチャート: 結合子", "フローチャート: 他ページ結合子", "フローチャート: カード", "フローチャート: せん孔テープ", "フローチャート: 和接合", "フローチャート: 論理和", "フローチャート: 照合", "フローチャート: 分類", "フローチャート: 抜出し", _

"フローチャート: 組合せ", "フローチャート: 記憶データ", "フローチャート: 論理積ゲート", "フローチャート: 順次アクセス記憶", "フローチャート: 磁気ディスク", "フローチャート: 直接アクセス記憶", "フローチャート: 表示", "爆発: 8 pt", "爆発: 14 pt", "星: 4 pt", _

"星: 5 pt", "星: 6 pt", "星: 7 pt", "星: 8 pt", "星: 10 pt", "星: 12 pt", "星: 16 pt", "星: 24 pt", "星: 32 pt", "リボン: 上に曲がる", _

"リボン: 下に曲がる", "リボン: カーブして上方向に曲がる", "リボン: カーブして下方向に曲がる", "スクロール: 縦", "スクロール: 横", "波線", "小波", "吹き出し: 四角形", "吹き出し: 角を丸めた四角形", "吹き出し: 円形", _

"思考の吹き出し: 雲形", "吹き出し: 線", "吹き出し: 折線", "吹き出し: 2 つ折線", "吹き出し: 線 (強調線付き)", "吹き出し: 折線 (強調線付き)", "吹き出し: 2 つ折線 (強調線付き)", "吹き出し: 線 (枠なし)", "吹き出し: 折線 (枠なし)", "吹き出し: 2 つ折線 (枠なし)", _

"吹き出し: 線 (枠付き、強調線付き)", "吹き出し: 折線 (枠付き、強調線付き)", "吹き出し: 2 つ折線 (枠付き、強調線付き)", "グループ化")

'Range("g1:g200") = WorksheetFunction.Transpose(ar11)

'Range("h1:h200") = WorksheetFunction.Transpose(ar12)

For i = 1 To 154

If dic_x.Exists(ar11(i)) = False Then

dic_x.Add ar11(i), ar12(i)

Else

End If

Next

 

End Sub

Sub 範囲取得()　　　セル間比率

Dim range1 As Range

Dim ar1() As Double

 Dim t1, total2 As Double

    Dim stcol, edcol, i, strow, edrow As Long

      Dim a1, b1 As String

Dim rui, n, j As Long

 

Dim MaxRow As Long

MaxRow = Cells(Rows.Count, "A").End(xlUp).Row

ReDim ar1(MaxRow, 3)

rui = 0

n = UBound(ar1, 1)

For i = 1 To n

ar1(i, 1) = Cells(i, "A")

rui = rui + ar1(i, 1)

'rui = 分割比率の合計

ar1(i, 2) = rui

Next

 

'    ' 結果をメッセージボックスに表示（例）

'    MsgBox "選択された範囲: " & selectedRange.Address

Dim selectedRange As Range

    Dim topLeftCell As Range

    Dim bottomRightCell As Range

    ' 現在選択されている範囲を取得

    Set selectedRange = Selection

    ' 範囲の左上のセルを取得

    Set topLeftCell = selectedRange.Cells(1, 1)

    ' 範囲の右下のセルを取得

    Set bottomRightCell = selectedRange.Cells(selectedRange.Rows.Count, selectedRange.Columns.Count)

    ' 結果をメッセージボックスに表示（例）

'    MsgBox "左上のセル: " & topLeftCell.Address & vbCrLf & "右下のセル: " & bottomRightCell.Address

    a1 = topLeftCell.Address

    b1 = bottomRightCell.Address

    '左上の行と列を取得

    Range(a1).Select

    strow = Selection.Row

    stcol = Selection.Column

'    右下の行と列を取得

    Range(b1).Select

     edrow = Selection.Row

    edcol = Selection.Column

    For i = strow To edrow

    Cells(1, i).Select

    t1 = t1 + Selection.ColumnWidth

    Next

    Dim keisu As Double

    keisu = t1 / rui      '1分割比率あたりの幅

    MsgBox t1 & "  ggg  " & rui & "   " & keisu

    For i = 1 To n

    ar1(i, 3) = ar1(i, 2) * keisu

'    MsgBox ar1(i, 3)

    Next

'    Exit Sub

    For j = 1 To n

    total2 = 0

    For i = stcol To edcol

     Cells(1, i).Select

     total2 = total2 + Selection.ColumnWidth

     If total2 > ar1(j, 3) Then

        MsgBox ar1(j, 3)

        MsgBox Selection.Column

        Exit For

      End If

    Next

    Next

    selectedRange.Select

End Sub

 

Sub 図形追加()

'Left,Top,Width,Height

ActiveSheet.Shapes.AddShape(msoShapeRectangle, 160.2, 99, 115.2, 69.6).Select

'   正方形 / 長方形

    ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 114.6, 148.8, 52.8 _

        , 32.4).Select        'テキスト ボックス 21

    ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 125.4, 199.8, 66.6, 20.4) _

        .Select                  '四角形: 角を丸くする

    ActiveSheet.Shapes.AddShape(msoShapeFlowchartOffpageConnector, 353.4, 207.6, _

        33.6, 34.2).Select    'フローチャート: 他ページ結合子

    ActiveSheet.Shapes.AddShape(msoShapeFlowchartDocument, 455.4, 241.2, 53.4, 40.2 _

        ).Select               'フローチャート: 書類

    ActiveSheet.Shapes.AddShape(msoShapeFlowchartMultidocument, 530.4, 216.6, 46.8 _

        , 49.8).Select      'ローチャート: 複数書類

    ActiveSheet.Shapes.AddShape(msoShapeFlowchartSummingJunction, 421.8, 290.4, _

        30.6, 25.8).Select        'フローチャート: 和接合 28

End Sub

図形の定率拡大/縮小

Private Sub CommandButton1_Click()

Dim shp As Shape

Dim per As Long

Dim ratio As Double

per = Val(TextBox1)

ratio = 1 + per / 100

Application.ScreenUpdating = False                'ディスプレイ出力抑止

For Each shp In Selection.ShapeRange  '拡大/縮小した図形の把握

If OptionButton1 = True Then

Selection.ShapeRange.ScaleWidth ratio, msoFalse, msoScaleFromTopLeft

 Selection.ShapeRange.ScaleHeight ratio, msoFalse, msoScaleFromTopLeft

Else

Selection.ShapeRange.ScaleWidth ratio, msoFalse, msoScaleFromTopLeft

End If

Next

Application.ScreenUpdating = True                'ディスプレイ出力

End Sub

 

Private Sub CommandButton2_Click()

Dim shp As Shape

Dim per As Long

Dim ratio  As Double

per = Val(TextBox1)

ratio = 1 / (1 + per / 100)

Application.ScreenUpdating = False                'ディスプレイ出力抑止

For Each shp In Selection.ShapeRange  '拡大/縮小した図形の把握

If OptionButton1 = True Then

Selection.ShapeRange.ScaleWidth ratio, msoFalse, msoScaleFromTopLeft

 Selection.ShapeRange.ScaleHeight ratio, msoFalse, msoScaleFromTopLeft

Else

Selection.ShapeRange.ScaleWidth ratio, msoFalse, msoScaleFromTopLeft

End If

Next

Application.ScreenUpdating = True                'ディスプレイ出力

End Sub

 

Private Sub UserForm_Initialize()

OptionButton1 = True

End Sub


Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr

Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As Long

Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Const GWL_STYLE = -16

Private Const WS_MAXIMIZEBOX = &H10000

Private Const WS_MINIMIZEBOX = &H20000

Private Const WS_THICKFRAME = &H40000

 

別フォームを呼び出すときに、自身を極小化する

Private Sub CommandButton3_Click()

Dim hWnd As LongPtr

hWnd = FindWindowA(vbNullString, "UF1")

ShowWindow hWnd, 6

UserForm1.Show vbModeless

End Sub

 

呼び出したフォームを終了するとき、元のフォームを拡大する

Private Sub CommandButton7_Click()

Dim hWnd As LongPtr

hWnd = FindWindowA(vbNullString, "UF1")

ShowWindow hWnd, 9

Unload Me

End Sub

ｘボタンを押させない 

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    '×ボタンを押しても閉じない
    
    If CloseMode = 0 Then
        MsgBox "×ボタンで閉じないでください"
        Cancel = 1 '閉じる操作をキャンセル
    End If
End Sub

矢印の逆転

Sub CheckConnector矢印方向()

Dim shp As Shape

Dim A1, A2, A12 As String

    ' 選択されている図形のうち最初の図形を取得

For Each shp In Selection.ShapeRange

    ' 図形がコネクタであることを確認

    If shp.Name Like "*Connector*" Or shp.Name Like "*ｺﾈｸﾀ*" Then

        ' コネクタの方向を判定

        If Selection.ShapeRange.Line.BeginArrowheadStyle = msoArrowheadTriangle Then

            A1 = "1"   '三角形

        ElseIf Selection.ShapeRange.Line.BeginArrowheadStyle = msoArrowheadStealth Then

            A1 = "2"      '矢印

        ElseIf Selection.ShapeRange.Line.BeginArrowheadStyle = msoArrowheadOpen Then

            A1 = "3"      '矢印線

        Else

            A1 = "4"      '開始印なし

        End If

        

        If Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadTriangle Then

            A2 = "1"

        ElseIf Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadStealth Then

            A2 = "2"

        ElseIf Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadOpen Then

            A2 = "3"

        Else

            A2 = "4"

        End If

    End If

    A12 = A1 & A2

    Select Case A12

        Case "41"

            Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadNone

            Selection.ShapeRange.Line.BeginArrowheadStyle = msoArrowheadTriangle

        Case "42"

            Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadNone

            Selection.ShapeRange.Line.BeginArrowheadStyle = msoArrowheadStealth

        Case "43"

            Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadNone

            Selection.ShapeRange.Line.BeginArrowheadStyle = msoArrowheadOpen

        Case "14"

            Selection.ShapeRange.Line.BeginArrowheadStyle = msoArrowheadNone

            Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadTriangle

        Case "24"

        Selection.ShapeRange.Line.BeginArrowheadStyle = msoArrowheadNone

            Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadStealth

        Case "34"

            Selection.ShapeRange.Line.BeginArrowheadStyle = msoArrowheadNone

            Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadOpen

        Case Else

    End Select

    Exit Sub

Next

End Sub

 

 

 

多図形のサイズ変更時の重心移動

Option Base 1

Public ar1()

Public arx() As Double

Public ary() As Double

Public Lc As Long

Public ach As String

rivate Sub CommandButton1_Click()  '図形記憶

Dim shp As Shape

Dim ch As Long

Dim i As Long

Erase arx            '各図形のスペック配列

Erase ar1            '各図形の名前配列

Lc = 0                  '選択されている図形の数

On Error Resume Next

If VarType(Selection) = vbObject Then

    Else

       MsgBox "図形は選択されていせん。"

    Exit Sub

  End If

For Each shp In Selection.ShapeRange    '選択されている図形の情報を順次取得

Lc = Lc + 1

ReDim Preserve ar1(Lc)

ReDim Preserve arx(6, Lc)

ar1(Lc) = shp.Name

arx(1, Lc) = shp.Top

arx(2, Lc) = shp.Left

arx(3, Lc) = shp.Height

arx(4, Lc) = shp.Width

arx(5, Lc) = arx(2, Lc) + (arx(4, Lc) / 2)    '左右の中心位置を求める

arx(6, Lc) = arx(1, Lc) + (arx(3, Lc) / 2)   '上下の中心位置を求める

Next

End Sub

 

Private Sub CommandButton2_Click()      '変更した図形の重心を元に戻す

Dim shp As Shape

Dim ch As Long

Dim i As Long

Dim H1() As Long

Dim L1() As Long

Dim ar2(1)

ReDim H1(Lc)

ReDim L1(Lc)

ReDim Preserve ary(6, Lc)

For i = 1 To Lc

ar2(1) = ar1(i)            '図形を選択するために　引数を配列にする必要がある

On Error Resume Next

Err.Clear

ActiveSheet.Shapes.Range(ar2).Select

If Err.Number <> 0 Then

MsgBox "図形が削除されています"

Err.Clear

Exit Sub

End If

For Each shp In Selection.ShapeRange  '拡大/縮小した図形の把握

ary(1, i) = shp.Top

ary(2, i) = shp.Left

ary(3, i) = shp.Height

ary(4, i) = shp.Width

ary(5, i) = ary(2, i) + (ary(4, i) / 2)

ary(6, i) = ary(1, i) + (ary(3, i) / 2)

Next

'シフト量算出

L1(i) = (arx(5, i) - ary(5, i))

H1(i) = (arx(6, i) - ary(6, i))

Selection.ShapeRange.IncrementLeft L1(i)      '左右の位置を補正

Selection.ShapeRange.IncrementTop H1(i)      '上下の位置を補正

Next

ActiveSheet.Shapes.Range(ar1).Select

End Sub

Private Sub CommandButton3_Click()      'センタリング

Dim shp As Shape

Dim ch As Long

Dim i As Long

Dim av1 As Double

Dim ar2(1)

Dim L1() As Long

Erase arx

Erase ar1

Lc = 0

On Error Resume Next

For Each shp In Selection.ShapeRange

Lc = Lc + 1

ReDim Preserve ar1(Lc)

ReDim Preserve arx(6, Lc)

ar1(Lc) = shp.Name

arx(1, Lc) = shp.Top

arx(2, Lc) = shp.Left

arx(3, Lc) = shp.Height

arx(4, Lc) = shp.Width

arx(5, Lc) = arx(2, Lc) + (arx(4, Lc) / 2)      '図形の左右中心

Next

ReDim L1(Lc)

'センタリング

'図形の左右中心の平均値を求める

For i = 1 To Lc

av1 = av1 + arx(5, i)

Next

av1 = av1 / Lc

'各図形をセンタリングするために中心医師（av)との差を求める

For i = 1 To Lc

L1(i) = av1 - arx(5, i)

'ReDim ary(6, Lc)

ar2(1) = ar1(i)

ActiveSheet.Shapes.Range(ar2).Select

'

Selection.ShapeRange.IncrementLeft L1(i)

Next

ActiveSheet.Shapes.Range(ar1).Select

 

End Sub

Private Sub CommandButton4_Click()      '左寄せ

Dim shp As Shape

Dim ch As Long

Dim i As Long

Dim av1 As Double

Dim ar2(1)

Dim L1() As Long

Erase arx

Erase ar1

Lc = 0

On Error Resume Next

For Each shp In Selection.ShapeRange

Lc = Lc + 1

ReDim Preserve ar1(Lc)

ReDim Preserve arx(6, Lc)

ar1(Lc) = shp.Name

arx(1, Lc) = shp.Top

arx(2, Lc) = shp.Left

arx(3, Lc) = shp.Height

arx(4, Lc) = shp.Width

arx(5, Lc) = arx(1, Lc) + (arx(3, Lc) / 2)      '図形の左右中心

Next

ReDim L1(Lc)

'左寄せ

'図形の左端最低値を求める

av1 = arx(5, 1)

For i = 1 To Lc

If arx(5, i) < av1 Then

av1 = arx(5, i)

End If

Next

'各図形をセンタリングするために中心医師（av)との差を求める

For i = 1 To Lc

L1(i) = av1 - arx(2, i)

'ReDim ary(6, Lc)

ar2(1) = ar1(i)

ActiveSheet.Shapes.Range(ar2).Select

Selection.ShapeRange.IncrementLeft L1(i)

Next

ActiveSheet.Shapes.Range(ar1).Select

End Sub

Private Sub CommandButton5_Click()

Dim shp As Shape

Dim ch As Long

Dim i As Long

Dim H1() As Long

Dim L1() As Long

Dim ar2(1)

ReDim H1(Lc)

ReDim L1(Lc)

For i = 1 To Lc

 

ReDim Preserve ary(6, Lc)

ar2(1) = ar1(i)

On Error Resume Next

 

ActiveSheet.Shapes.Range(ar2).Select

'If Error Then

'MsgBox "図形が削除されています"

'Exit Sub

'End If

 

'For Each shp In Selection.ShapeRange

ary(1, i) = arx(1, i)

ary(2, i) = arx(2, i)

ary(3, i) = arx(3, i)

ary(4, i) = arx(4, i)

'ary(5, i) = ary(2, i) + (ary(4, i) / 2)

'ary(6, i) = ary(1, i) + (ary(3, i) / 2)

'Next

'シフト量算出

'L1(i) = (arx(5, i) - ary(5, i))

'H1(i) = (arx(6, i) - ary(6, i))

MsgBox ary(1, 1)

Selection.ShapeRange.IncrementTop (ary(1, i) * -1)

 

Selection.ShapeRange.IncrementLeft (ary(2, i) * -1)

Selection.ShapeRange.Height ary(3, i)

Selection.ShapeRange.Width ary(4, i)

Next

ActiveSheet.Shapes.Range(ar1).Select

End Sub

 

***************************************************************************************

ar1とlcはpublic宣言しておく  リストボックスを使ったセルの選択

Private Sub UserForm_Initialize()

Dim hwnd As LongPtr

hwnd = FindWindow("ThunderDFrame", Me.Caption)

SetWindowLong hwnd, -16, GetWindowLong(hwnd, -16) Or &H70000

End Sub

Private Sub cm1_Click()   '図形の個別選択を記憶、リストボックス表示

Dim shp As Shape

Dim ch As Long

Dim i As Long

On Error Resume Next

If VarType(Selection) = vbObject Then

    Else

       MsgBox "図形は選択されていせん。"

    Exit Sub

  End If

For Each shp In Selection.ShapeRange

With UF1.ListBox1

.AddItem ""

.List(Lc, 0) = shp.Name

Lc = Lc + 1

ReDim Preserve ar1(Lc)

ar1(Lc) = shp.Name

End With

Next

End Sub

Private Sub cm2_Click()      '記憶した図形を選択状態にする

If (Not ar1) = -1 Then

MsgBox "何も選択されていません"

Else

ActiveSheet.Shapes.Range(ar1).Select

End If

End Sub

Private Sub ListBox1_Click()    'リストボックスをクリックしたとき、その図形を選択

Dim ar2(1)

Dim i As Long

With UF1.ListBox1

i = UF1.ListBox1.ListIndex

ar2(1) = ar1(i + 1)

ActiveSheet.Shapes.Range(ar2).Select

End With

End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

Dim ar2(1)

Dim i, k As Long

With UF1.ListBox1

k = UF1.ListBox1.ListIndex

For i = k + 2 To UBound(ar1)

ar1(i - 1) = ar1(i)

Next i

'■配列を再定義し、最終の要素を詰める

ReDim Preserve ar1(UBound(ar1) - 1)

Lc = Lc - 1

For i = ListBox1.ListCount - 1 To 0 Step -1

If ListBox1.Selected(k) Then

ListBox1.RemoveItem (k)

Exit For

End If

Next

End With

End Sub

Private Sub CommandButton1_Click()  'リストボックスのクリア

ListBox1.Clear

Lc = 0

Erase ar1

Range("A1").Select

End Sub

Private Sub CommandButton2_Click()  'リストの重複削除

Dim dic_1 As Object

Dim ar3()

Dim i, k As Long

If (Not ar1) = -1 Then

MsgBox "何も選択されていません"

Else

Set dic_1 = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(ar1)

If dic_1.Exists(ar1(i)) = False Then

dic_1.Add ar1(i), i

k = k + 1

ReDim Preserve ar3(k)

ar3(k) = ar1(i)

End If

Next

Erase ar1

ar1 = ar3

ListBox1.Clear

Lc = 0

For i = 1 To UBound(ar1)

With UF1.ListBox1

.AddItem ""

.List(i - 1, 0) = ar1(i)

Lc = Lc + 1

End With

Next

End If

End Sub

 

 

ユーザーフォームをアンダーバーで小さくする方法

フォームモジュールに追加します

Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr

Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long

Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

 

Private Sub UserForm_Initialize()

Dim hwnd As LongPtr

hwnd = FindWindow("ThunderDFrame", Me.Caption)

SetWindowLong hwnd, -16, GetWindowLong(hwnd, -16) Or &H70000

End Sub

フォームをxで閉じようとしたとき 

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = vbFormControlMenu Then
        MsgBox "［閉じる］ボタンを使用してください"
        Cancel = True
    End If
End Sub

IF フォーム_A.Visible Then などと組み合わせて、他のフォーム（子どもの関係）が生きているとき、警告を出したりする

Sub 図形接続線描画()

'実行前に2つの図を選択しておく必要があります

Dim shp_n As String

Dim shp_ary(2)

Dim n1, n2, i As Long

Dim shp  As Shape

Dim shv(2)  As Shape

Dim sh_1 As String

Dim sh_2 As String

Dim top_ary(2) As Double

Dim base_flg As Long

Dim hx(2) As Integer

Dim hen, knd, y_mark As String

 

'外部変数入力　1 = 上下　2 = 左右

hen = InputBox("上か左右か")

knd = InputBox("カギか直線か曲線か")

y_mark = InputBox("三角、鋭角、線")

On Error Resume Next

hx(0) = 1    '配列インデックス0に代入してエラーが起きるかどうか確かめる

If Err.Number <> 0 Then  '  エラーが出たらoptionbase 指定がされている

    base_flg = 1

Else

    base_flg = 0

End If

With ActiveSheet

On Error GoTo err1

If Selection.ShapeRange.Count > 1 Then

    For Each shp In Selection.ShapeRange

        i = i + 1

        shp_ary(i) = shp.Name   '図形名を記憶する

       

        If Val(hen) = 1 Then

            top_ary(i) = shp.Top      '図形の位置関係を確認するため高さまたは左からの位置を取得する

        Else

            top_ary(i) = shp.Left

        End If

    Next

    If i > 2 Then

        MsgBox "図形が3つ以上選択されています"

        Exit Sub

    End If

Else      '図形が選択されていなかった場合

err1:

    Err.Clear

    MsgBox "図形が2つ選択されていません"

    Exit Sub

End If

End With

 

On Error Resume Next    '矢印の方向を決めるため上（左）の図形名称を決定する

If top_ary(1) < top_ary(2) Then

    sh_1 = shp_ary(1)

    sh_2 = shp_ary(2)

Else

    sh_1 = shp_ary(2)

    sh_2 = shp_ary(1)

End If

 

Select Case Val(knd)

    Case 1

        ActiveSheet.Shapes.AddConnector(msoConnectorElbow, 10, 10, 10, 10).Select

        '罫線で図形を連結する場合にはそのサイズは問わない

    Case 2

        ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 10, 10, 10, 10).Select

    Case Else

        ActiveSheet.Shapes.AddConnector(msoConnectorCurve, 10, 10, 10, 10).Select

End Select

shp_n = Selection.Name

Selection.Name = changeEngToJpn(shp_n)

'矢印の種類を決める

Select Case Val(y_mark)

    Case 1

        Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadTriangle

    Case 2

        Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadStealth

    Case Else

        Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadOpen

End Select

'罫線接続変数を決める　1=図形上中央　2=左中央　3=下中央　4=右中央

If Val(hen) = 1 Then    '上下接続か、左右接続か

   n1 = 3          '上（左）の図形の接続点

   n2 = 1           '下（右）の図形の接続点

Else

  n1 = 4

  n2 = 2

End If

'接続線の描画

Selection.ShapeRange.ConnectorFormat.BeginConnect ActiveSheet.Shapes(sh_1), n1

Selection.ShapeRange.ConnectorFormat.EndConnect ActiveSheet.Shapes(sh_2), n2

'最初選んでいた図形を選びなおす

ActiveSheet.Shapes.Range(Array(shp_ary(1), shp_ary(2))).Select

End Sub

図形の英文を和文に変更

Public Function changeEngToJpn(変換対象 As String) As String

Dim 図形名本体 As String, 図形名連番 As String

Dim 図形名英文配列 As Variant, 図形名和文配列 As Variant, st_buf() As String

Dim id As Integer

Dim hx(2) As Integer

Dim opflg As Long

On Error Resume Next

    hx(0) = 1    'エラーが起きる

' モジュールのコードを取得

 If Err.Number <> 0 Then

       opflg = 0

    Else

        ' Option Baseステートメントが見つからなかった場合（デフォルトはOption Base 0）

       opflg = -1

End If

Err.Clear

Const iMax As Integer = 39  '固定長の長さ

    図形名英文配列 = Array("Straight Connector                     001", "Straight Arrow Connector               002", "Elbow Connector                        003", "Curved Connector                       004", "Freeform                               005", "Rectangle                              006", "Rounded Rectangle                      007", "Snip Single Corner Rectangle           008", "Snip Same Side Corner Rectangle        009", "Snip Diagonal Corner Rectangle         010", _

        "Snip and Round Single Corner Rectangle 011", "Round Single Corner Rectangle          012", "Round Same Side Corner Rectangle       013", "Round Diagonal Corner Rectangle        014", "TextBox                                015", "Oval                                   016", "Isosceles Triangle                     017", "Right Triangle                         018", "Parallelogram                          019", "Trapezoid                              020", _

        "Diamond                                021", "Regular Pentagon                       022", "Hexagon                                023", "Heptagon                               024", "Octagon                                025", "Decagon                                026", "Dodecagon                              027", "Pie                                    028", "Chord                                  029", "Teardrop                               030", _

        "Frame                                  031", "Half Frame                             032", "L-Shape                                033", "Diagonal Stripe                        034", "Cross                                  035", "Plaque                                 036", "Can                                    037", "Cube                                   038", "Bevel                                  039", "Donut                                  040", _

        "No Symbol                              041", "Block Arc                              042", "Folded Corner                          043", "Smiley Face                            044", "Heart                                  045", "Lightning Bolt                         046", "Sun                                    047", "Moon                                   048", "Cloud                                  049", "Arc                                    050", _

        "Double Bracket                         051", "Double Brace                           052", "Left Bracket                           053", "Right Bracket                          054", "Left Brace                             055", "Right Brace                            056", "Right Arrow                            057", "Left Arrow                             058", "Up Arrow                               059", "Down Arrow                             060", _

        "Left-Right Arrow                       061", "Up-Down Arrow                          062", "Quad Arrow                             063", "Left-Right-Up Arrow                    064", "Bent Arrow                             065", "U-Turn Arrow                           066", "Left-Up Arrow                          067", "Bent-Up Arrow                          068", "Curved Right Arrow                     069", "Curved Left Arrow                      070", _

        "Curved Up Arrow                        071", "Curved Down Arrow                      072", "Striped Right Arrow                    073", "Notched Right Arrow                    074", "Pentagon                               075", "Chevron                                076", "Right Arrow Callout                    077", "Down Arrow Callout                     078", "Left Arrow Callout                     079", "Up Arrow Callout                       080", _

        "Left-Right Arrow Callout               081", "Quad Arrow Callout                     082", "Circular Arrow                         083", "Plus                                   084", "Minus                                  085", "Multiply                               086", "Division                               087", "Equal                                  088", "Not Equal                              089", "Flowchart: Process                     090", _

        "Flowchart: Alternate Process           091", "Flowchart: Decision                    092", "Flowchart: Data                        093", "Flowchart: Predefined Process          094", "Flowchart: Internal Storage            095", "Flowchart: Document                    096", "Flowchart: Multidocument               097", "Flowchart: Terminator                  098", "Flowchart: Preparation                 099", "Flowchart: Manual Input                100", _

        "Flowchart: Manual Operation            101", "Flowchart: Connector                   102", "Flowchart: Off-page Connector          103", "Flowchart: Card                        104", "Flowchart: Punched Tape                105", "Flowchart: Summing Junction            106", "Flowchart: Or                          107", "Flowchart: Collate                     108", "Flowchart: Sort                        109", "Flowchart: Extract                     110", _

        "Flowchart: Merge                       111", "Flowchart: Stored Data                 112", "Flowchart: Delay                       113", "Flowchart: Sequential Access Storage   114", "Flowchart: Magnetic Disk               115", "Flowchart: Direct Access Storage       116", "Flowchart: Display                     117", "Explosion 1                            118", "Explosion 2                            119", "4-Point Star                           120", _

        "5-Point Star                           121", "6-Point Star                           122", "7-Point Star                           123", "8-Point Star                           124", "10-Point Star                          125", "12-Point Star                          126", "16-Point Star                          127", "24-Point Star                          128", "32-Point Star                          129", "Up Ribbon                              130", _

        "Down Ribbon                            131", "Curved Up Ribbon                       132", "Curved Down Ribbon                     133", "Vertical Scroll                        134", "Horizontal Scroll                      135", "Wave                                   136", "Double Wave                            137", "Rectangular Callout                    138", "Rounded Rectangular Callout            139", "Oval Callout                           140", _

        "Cloud Callout                          141", "Line Callout 1                         142", "Line Callout 2                         143", "Line Callout 3                         144", "Line Callout 1 (Accent Bar)            145", "Line Callout 2 (Accent Bar)            146", "Line Callout 3 (Accent Bar)            147", "Line Callout 1 (No Border)             148", "Line Callout 2 (No Border)             149", "Line Callout 3 (No Border)             150", _

        "Line Callout 1 (Border and Accent Bar) 151", "Line Callout 2 (Border and Accent Bar) 152", "Line Callout 3 (Border and Accent Bar) 153", "Group                                  154")

    If InStrRev(変換対象, " ") = 0 Then    '連番が付番されていない場合

        図形名本体 = 変換対象

        図形名連番 = ""

    Else                                                      '連番が付番されてる場合　本体名と　連番に切り離す

        図形名本体 = Mid(変換対象, 1, InStrRev(変換対象, " ") - 1)  '図形名

        図形名連番 = Mid(変換対象, InStrRev(変換対象, " "))  '半角スペース＋連番

    End If

    図形名本体 = 図形名本体 & Space(iMax - Len(図形名本体))  '固定長にする　設定最大文字数から本体文字数を引いて　その差数の　スペースを付加

    st_buf = Filter(図形名英文配列, 図形名本体)  'Filterは結果を配列で返す　図形名英文配列が無駄に長いのは、部分位置でフィルターにかからないため

    If UBound(st_buf) <> -1 Then                'option base 1 の時は　0

    id = Replace(st_buf(0), 図形名本体, "") + opflg  '添え字を取得   'option base 1 の時は　0

                                                                           '添え字を取得   'option base 1 の設定がされていない時 -1

    図形名和文配列 = Array("直線コネクタ", "直線矢印コネクタ", "コネクタ: カギ線", "コネクタ: 曲線", "フリーフォーム: 図形", "正方形/長方形", "四角形: 角を丸くする", "四角形: 1 つの角を切り取る", "四角形: 上の 2 つの角を切り取る", "四角形: 対角を切り取る", _

    "四角形: 1 つの角を切り取り 1 つの角を丸める", "四角形: 1 つの角を丸める", "四角形: 上の 2 つの角を丸める", "四角形: 対角を丸める", "テキスト ボックス", "楕円", "二等辺三角形", "直角三角形", "平行四辺形", "台形", _

            "ひし形", "五角形", "六角形", "七角形", "八角形", "十角形", "十二角形", "部分円", "弦", "涙形", _

            "フレーム", "フレーム (半分)", "L 字", "斜め縞", "十字形", "ブローチ", "円柱", "直方体", "四角形: 角度付き", "円: 塗りつぶしなし", _

            "禁止マーク", "アーチ", "四角形: メモ", "スマイル", "ハート", "稲妻", "太陽", "月", "雲", "円弧", _

            "大かっこ", "中かっこ", "左大かっこ", "右大かっこ", "左中かっこ", "右中かっこ", "矢印: 右", "矢印: 左", "矢印: 上", "矢印: 下", _

            "矢印: 左右", "矢印: 上下", "矢印: 四方向", "矢印: 三方向", "矢印: 折線", "矢印: U ターン", "矢印: 二方向", "矢印: 上向き折線", "矢印: 右カーブ", "矢印: 左カーブ", _

            "矢印: 上カーブ", "矢印: 下カーブ", "矢印: ストライプ", "矢印: V 字型", "矢印: 五方向", "矢印: 山形", "吹き出し: 右矢印", "吹き出し: 下矢印", "吹き出し: 左矢印", "吹き出し: 上矢印", _

            "吹き出し: 左右矢印", "吹き出し: 四方向矢印", "矢印: 環状", "加算記号", "減算記号", "乗算記号", "除算記号", "次の値と等しい", "等号否定", "フローチャート: 処理", _

            "フローチャート: 代替処理", "フローチャート: 判断", "フローチャート: データ", "フローチャート: 定義済み処理", "フローチャート: 内部記憶", "フローチャート: 書類", "フローチャート: 複数書類", "フローチャート: 端子", "フローチャート: 準備", "フローチャート: 手操作入力", _

            "フローチャート: 手作業", "フローチャート: 結合子", "フローチャート: 他ページ結合子", "フローチャート: カード", "フローチャート: せん孔テープ", "フローチャート: 和接合", "フローチャート: 論理和", "フローチャート: 照合", "フローチャート: 分類", "フローチャート: 抜出し", _

            "フローチャート: 組合せ", "フローチャート: 記憶データ", "フローチャート: 論理積ゲート", "フローチャート: 順次アクセス記憶", "フローチャート: 磁気ディスク", "フローチャート: 直接アクセス記憶", "フローチャート: 表示", "爆発: 8 pt", "爆発: 14 pt", "星: 4 pt", _

            "星: 5 pt", "星: 6 pt", "星: 7 pt", "星: 8 pt", "星: 10 pt", "星: 12 pt", "星: 16 pt", "星: 24 pt", "星: 32 pt", "リボン: 上に曲がる", _

            "リボン: 下に曲がる", "リボン: カーブして上方向に曲がる", "リボン: カーブして下方向に曲がる", "スクロール: 縦", "スクロール: 横", "波線", "小波", "吹き出し: 四角形", "吹き出し: 角を丸めた四角形", "吹き出し: 円形", _

            "思考の吹き出し: 雲形", "吹き出し: 線", "吹き出し: 折線", "吹き出し: 2 つ折線", "吹き出し: 線 (強調線付き)", "吹き出し: 折線 (強調線付き)", "吹き出し: 2 つ折線 (強調線付き)", "吹き出し: 線 (枠なし)", "吹き出し: 折線 (枠なし)", "吹き出し: 2 つ折線 (枠なし)", _

            "吹き出し: 線 (枠付き、強調線付き)", "吹き出し: 折線 (枠付き、強調線付き)", "吹き出し: 2 つ折線 (枠付き、強調線付き)", "グループ化")

        changeEngToJpn = 図形名和文配列(id) & 図形名連番

    Else

        changeEngToJpn = 変換対象

    End If

End Function

Public Sub font取得()

   Dim itm As Object

  Const CSIDL_FONTS = 20

  Dim arry1()

   Dim i As Long

   

   With CreateObject("Shell.Application").Namespace(CSIDL_FONTS)

    For Each itm In .Items

    i = i + 1

    ReDim Preserve arry1(i)

       arry1(i) = .GetDetailsOf(itm, 8)

    Next

  End With

  Range("M1").Resize(i, 1) = WorksheetFunction.Transpose(arry1)

End Sub

IF文の基本形

 

条件を満たさなかったときには何もしない

IF  CELLS(1,1) = 1 THEN 

 CELLS(1,2) = 2

ENDIF

 

または

IF  CELLS(1,1) = 1 THEN  CELLS(1,2) = 2

 

条件を満たさなかったときに別の処理をする

IF  CELLS(1,1) = 1 THEN 

 CELLS(1,2) = 2

ELSE

 CELLS(1,2) = 3

ENDIF

 

複数の条件で処理を変える（Ifnのネスト構造）

例：食べ放題の料金算出　A列性別　B列年齢　C列料金

IF  CELLS(1,"A") = "男"  THEN

　　if  Cells(1,"B")  > 15 Then

          Cells(1,"C") = 2800

    else

          Cells(1,"C") = 1000

    End if

Else

    if  Cells(1,"B")  > 15 Then

          Cells(1,"C") = 2300

    else

          Cells(1,"C") = 800

    End if

End if

 

Ifには複合条件（or and)も設定できますが

余事象（else)の条件が読み取りにくくなったり

条件の設定漏れが発生することに注意しなければいけません。

 

またExcelSheetと違い、VBAのIFは処理の分岐にも使用します

例：If cells(i,1) = "" then Exit Sub

取得したセルの値がNullならば、処理を終了する

 

比較対象が文字の時は　""　でくくる

例：IF  CELLS(1,1) = "A" THEN  CELLS(1,2) = 2

 

IF の代表的な比較演算子

=、>、<、>=、<=、<> (≠）

比較演算子だけではなく、結果がTrueがFalseの値を返してくれる関数はすべて使えます

代表例

If Cells(1,1) Like *AB*   Then ～　　　ABを含むならば

If Left(cells(1,1),2) = "AB" Then ～ 　ABではじまるならば

LeftはExcel関数をそのまま使えますが、使えない関数もあります

If WorksheetFunction.RoundUp(Cells(1, 1), 0) = 10 Then 

またVBAとExcelでは異なる関数もあります

Excel :=TEXT(A2,""yyyymmdd")

VBA   :Cells(2, 2) = Format(Cells(1, 1), "yyyymmdd")

 

比較文は　意味のない式は全て　True になり　型が違うと全て　Falseになる

If Cells(1, 1) = 100 Or 200 Then MsgBox "true"　

　　　　（文法に沿っていないので全てTrue)

If Cells(1, 1) = 100 Then msgbox  "true"　

　　　   (cells(1,1) が　"100"ならば　False

Excelシートで日付を見たら親の仇だと思え

　　　Excel シートの日付は VBAでは内部的に浮動小数点付き少数として扱われます。

　　  　⇒Format関数で文字列型に変換して使用しなければいけないケースが多々あります。

          日付型に使う関数と数字型に使う関数は全く別で　VBAで日付を扱う時は

　　　日付用関数を使用しなければいけませんが、他の場所で使用するときは文字型に変換

　　　　　　例　Cells(1, 2) = DateAdd("d", 3, Cells(1, 1))

　　　　　　　　Excel では日付型に加算すると無条件に【日】が追加されますが

　　　　　　　　VBAでは専用の関数が用意されています。

　　

ExcelシートとVBAでは【型】の考えが全く違います

　　　Excelシート　⇒　見え型

　　　ExcelVBA     ⇒　型

　たおえば　Cells(3,3) をシート上　文字列に設定します

　　　100　を　記入します　⇒　100

　　　100　* 2 を記入します　⇒　100*2 と表示されます

　　　ところが　cells(3,4) に　cells(3,3) * 2 と入れると　200　と表示されます

　　　⇒　そのセルでは文字列型でも計算に使うと数字型として扱われます

　　　VBAで　cells(3,4) = cells(3,3)  * 2 を実行するとエラーになります　 ’型が一致しません'

 

まとめると

　If文を使いこなすには

　　(1)If文そのものの文法を覚える

　　(2)If文は必ず条件の評価(True or False)が伴うので

　　　　比較演算子と関数を使えるようにします

　　(3)比較演算子や関数は使用する項目の【型】に依存するので

　　　　変数やセルの値の【型】を意識する必要があります

　　(4)扱いたい変数やセルが期待した型でないときは、関数を使って

　　　　（値を変えないまま）型を変更する技術が必要になります

 

Sub TEST1()

Dim ws As Worksheet

Dim i, MaxRow As Long

Dim MyDir, sh_name, NextexPath  As String

MyDir = ActiveWorkbook.Path

Sheets("Sheet1").Range("C:C").Copy Sheets("Sheet2").Range("A:A")

Sheets("Sheet2").Range("A:A").RemoveDuplicates Columns:=Array(1), Header:=xlYes

MaxRow = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row

For i = 2 To MaxRow

sh_name = Sheets("Sheet2").Cells(i, 1).Value

On Error Resume Next

Application.DisplayAlerts = False

Sheets(sh_name).Delete

Application.DisplayAlerts = True

Error.Clear

Next

For i = 2 To MaxRow

   Sheets("Sheet1").Select

   sh_name = Sheets("Sheet2").Cells(i, 1).Value

   Sheets("Sheet1").Copy After:=Sheets(Sheets.Count)

   Set ws = ActiveSheet

    ws.Name = sh_name

    If ActiveSheet.AutoFilterMode Then

    Else

    Rows("1:1").Select

    Selection.AutoFilter

    End If

  ws.Range("A1:E" & MaxRow).AutoFilter Field:=3, Criteria1:=sh_name

  NextexPath = MyDir & "\" & sh_name & ".pdf"

    ws.ExportAsFixedFormat _

        Type:=xlTypePDF, _

        Filename:=sh_name

 

ThisWorkbook.ExportAsFixedFormat _

        Type:=xlTypePDF, _

         filename:=exPath

 

  Next

End Sub


Private Sub UserForm_Initialize() 　　StartUpPosition = 　00'手動

　　Me.Left = 　100

　　Me.Top = 　　100
　　'startupposition = 1　'Excelの中央 　　'startupposition = 2　'画面の中央 　　'startupposition = 3　'画面の左上 End Sub

For 文の基本

For文について述べる前に、VBAの特徴について

 

最初から極論ですが　、vbaには　一つの命令で一つのセルの値を

書き換えることしかできません。

そして、その一つのセルの位置を決めるために1つ以上の命令を使うことが

多々あります。

 

Excl関数がたくさん入っているシートは、どおかのセルの値が変更されると

（瞬時に）関係する他のセルの表示を変えることができます。

 

それに比べてVBAはマクロを実行しないとセルの値は変更されません。

またセルの中を覗いても（関数と違って）どうしてその値になっているかもわかりません。

 

一般には　VBA > Excel関数  = VBAできるほうが関数使える人のほうがエライ

という先入観があるかもしれませんが

 

【計算】に関し絵は　Excel関数　> VBA　なのです

まあ関数でやると式が複雑すぎて解析できないというような例外もありますが。

 

VBAが関数より使いやすい点は

最終的に作りたい表の形式が一定でない場合（抽出や列の編集）、表と表の突合せや統合

小計だけを取り出す（ピポッドテーブル的な処理）

そして強力な編集機能です。（残業明細、給与基本データ、その他のデータから給与支給明細とか銀行別振込依頼書尾を作るなど）

一方メンバーとか要素が決まっている場合（生徒別科目別得点から各種順位や偏差値を計算する）などの場合関数のほうが有利となります。

 

ただ、どちらが優位かというのはVBAの基本機能（当然関数の基本機能も）わかっていないと判断できません。

 

その判断の基準となり大きな要素がIF文と、これから説明するFor文です

 

for文というのはいろいろな所で使われますが

最大（最頻といってもよいかも）昨日は

『1セルずつしか算出できないVBAの機能に対して』

【最初にどのセルに書き込むか】

【次回以降どセルに書き込むか】

【どのせるまで書き込んで処理を終了するか】

のコントロールにかかわるということです。

 

今までの例文では常に書き込む（セルに値を代入する）位置は固定でした。

cells(1,1)とか、これでは10行あるデータには10行の命令を作らなくてはいけません。

まして、何行あるか変動する場合、プログラミングのしようがありません。

 

そこで一般的な（あくまで一般的な）VBAプログラミングでは次のような手順をとります。

1.正規系のデータを作る（見出しとデータをセットで作る、key項目を決める、表と表の関係性

　が成立する場合、成立しない場合の条件、処理を決めておく）

　（これは最初あまり気にする必要はないです。ケースバイケースで場当たり的に決める場合も多いです）

2.元データと別のところに結果を編集する表を作成する

　　（VBAは一度編集作業をすると、元の表はなくなってしまうから）

　この処理の中には、前回の算出結果をクリアーする　も含まれます

3.対象範囲や算出範囲を決める。

4.その範囲を網羅するシナリオ（手順）を作成する

5.4.をもとに具体的なfor文を作成する。インデックスを決める。

6.for文を作成する

 

逆な言い方をすると、最終的に作りたい表をイメージして

1.その行は元データと同じか　（抽出と編集　1行を2行にするというような場合も）

2.シートをコピーする

3.最終的に表示したい行を項目（列）は何か決めて抽出する

　（そのあとの手順と並行して実行する場合もあります）

 

3.見た目の表の始終業を、具体的な数字に置きなおすす

　開始行を決める

VBA（Visual Basic for Applications）の"For...Next"ステートメントは、指定された回数だけコードブロックを繰り返し実行するための機能です。以下に、VBAの"For...Next"ステートメントについて理解するための教材の例をご紹介します。

 

ループの基本構文：

VBAの"For...Next"ステートメントは、以下のような基本的な構文を持ちます。

 

vba

Copy code

For [カウンター変数] = [初期値] To [終了値] [Step [ステップ値]]

    ' 実行したいコード

Next [カウンター変数]

カウンター変数はループの回数をカウントするための変数であり、初期値から終了値までステップ値ごとに増加または減少します。ステップ値は省略可能で、指定しない場合はデフォルトで1となります。

 

単純なループの例：

 

vba

Copy code

Sub SimpleLoopExample()

    Dim i As Integer

    For i = 1 To 5

        MsgBox "現在の値は " & i & " です。"

    Next i

End Sub

この例では、変数iが1から5までの範囲で1ずつ増加し、各回でメッセージボックスが表示されます。

 

ステップ値を指定する例：

 

vba

Copy code

Sub StepValueExample()

    Dim i As Integer

    For i = 10 To 1 Step -2

        MsgBox "現在の値は " & i & " です。"

    Next i

End Sub

この例では、変数iが10から1まで2ずつ減少し、各回でメッセージボックスが表示されます。

 

これらの例を通じて、VBAの"For...Next"ステートメントの基本的な使い方を理解できると思います。さらに、実際のプロジェクトや課題に応じて応用的な使い方