質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

90.34%

  • VBA

    1906questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

  • Excel

    1637questions

    Excelは、マイクロソフト社が開発しているデータ集計や分析を行う表計算ソフトの一つです。文書作成や表計算、資料作成などの多彩な機能を備えており、統合パッケージであるMicrosoft Officeに含まれています。

インデックスエラーがわからない~プログラム~

受付中

回答 0

投稿 編集

  • 評価
  • クリップ 0
  • VIEW 201

jun_endo

score 48

やりたいこと

質問内容
上記の質問のプログラムのみを
書き込んだフォームです。
質問内容については、リンク先に飛んでください。

Option Explicit

Public sn As Integer: Public sw As Integer
Dim row As Long, n As Long
Public 右上座標x, 右下座標x, 左上座標x, 左下座標x As Variant
Public 右上座標y, 右下座標y, 左上座標y, 左下座標y As Variant
Public 始点x As Variant, 始点y As Variant, 差分x As Integer
Public 終点x As Variant, 終点y As Variant, 差分y As Integer
---------------------------------------------------------------------

Sub 寸法取得()

'シート数を数える
sn = Worksheets.Count



Dim 横線(), 縦線(), 石番号() As Variant
Dim 横 As Integer, 縦 As Integer, 石 As Integer

row = 2: 縦 = 0: 横 = 0: 石 = 0

'動的配列
ReDim Preserve 横線(横), 縦線(縦), 石番号(石)

'シートを指定する(アクティブ)
With Sheets(sn)

    'シートの空白行まで
    Do While .Cells(row, 1) <> ""

        'セルの中身が石番号なら別の処理をする
        If .Cells(row, 1) <> "●18石番号" Then

            '各画層の始点と終点のx,yの値を代入する
            始点x = .Cells(row, 2): 始点y = .Cells(row, 3)
            終点x = .Cells(row, 4): 終点y = .Cells(row, 5)

            'xの始点と終点の値が同じならそれは縦線
            If 始点x = 終点x Then
                '縦線は(y始点,y終点,xの座標)のコンマ区切りの文字列
                縦線(縦) = 始点y & "," & 終点y & "," & 始点x
                '(xは終始同じ数値なので始点のみ記述)
                縦 = 縦 + 1
                ReDim Preserve 縦線(縦)
            Else
                'yの始点と終点の値が同じならそれは横線
                If 始点y = 終点y Then
                    '横線は(x始点,x終点,yの座標)のコンマ区切りの文字列
                    横線(横) = 始点x & "," & 終点x & "," & 始点y
                    '(yは終始同じ数値なので始点のみ記述)
                    横 = 横 + 1
                    ReDim Preserve 横線(横)
                End If
            End If
        Else
            '石番号は(x座標,y座標,石番号)のコンマ区切りの文字列
            石番号(石) = .Cells(row, 2) & "," & .Cells(row, 3) & "," & .Cells(row, 7)
            石 = 石 + 1
            ReDim Preserve 石番号(石)
        End If
        row = row + 1
    Loop
End With

Dim 固定比較, 流動比較, 交点() As Variant
'基準となる変数=固定比較
'比較時に基準とならない変数=流動比較

Dim 交 As Integer, n_2 As Long, xn As Long

交 = 0

ReDim Preserve 交点(0)

'縦線を中心に交点を求めていく
For n = 0 To 縦 - 1
    '縦線の文字列をコンマで分割する
    固定比較 = Split(縦線(n), ",")
    For n_2 = 0 To 横 - 1
        '横線の文字列をコンマで分割する
        流動比較 = Split(横線(n_2), ",")

        '交点が縦と横の線それぞれの範囲内に存在するか調べる
        If 固定比較(0) <= 流動比較(2) And 流動比較(2) >= 固定比較(1) And _
           流動比較(0) <= 固定比較(2) And 固定比較(2) >= 流動比較(1) Then
                '
                '交点は(x座標,y座標)のコンマ区切りの文字列
                交点(交) = 固定比較(2) & "," & 流動比較(2)
                交 = 交 + 1
                ReDim Preserve 交点(交)
        End If
    Next n_2
Next n


Dim x軸() As Variant

ReDim x軸(0)
xn = 0

'交点と交点を結ぶ線分の探索
For n = 0 To 交 - 1
    固定比較 = Split(交点(n), ",")

    For n_2 = n + 1 To 交 - 1
        流動比較 = Split(交点(n_2), ",")

        '横線の条件に一致しているかを調べる
        If 固定比較(1) = 流動比較(1) Then

            '数値の大小を調べて始点、終点を決める
            If 固定比較(0) < 流動比較(0) Then
                'x軸は(始点x,始点y,終点x,終点y)のコンマ区切りの文字列
                x軸(xn) = 交点(n) & "," & 交点(n_2)
            Else
                x軸(xn) = 交点(n_2) & "," & 交点(n)
            End If
            xn = xn + 1
            ReDim Preserve x軸(xn)
        End If
    Next n_2
Next n

Dim 交四点() As Variant, fn As Long
fn = 0
ReDim 交四点(0)

'横線を決めたので、それぞれの横線の長さが同じものを探索する
For n = 0 To xn - 1
    固定比較 = Split(x軸(n), ",")
    For n_2 = n + 1 To xn - 1
        'MsgBox (UBound(x軸))
        流動比較 = Split(x軸(n_2), ",")

        'x座標が同じものを探索
        If 固定比較(0) = 流動比較(0) And 固定比較(2) = 流動比較(2) Then
            If 固定比較(1) < 流動比較(1) And 固定比較(3) < 流動比較(3) Then

                '交四点は(上辺に当たるx軸,底辺に当たるx軸)のコンマ区切りの文字列
                交四点(fn) = x軸(n) & "," & x軸(n_2)
            Else
                交四点(fn) = x軸(n_2) & "," & x軸(n)
            End If

            fn = fn + 1
            ReDim Preserve x軸(fn)
        End If
    Next n_2
Next n
'現在のシートの枚数
sn = Worksheets.Count

'シートの追加
Worksheets().Add After:=Worksheets(sn)
'表示
For n = 0 To fn -1
Sheets(sn+1).cells(n,1) = x軸(n)
Next n
  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

まだ回答がついていません

同じタグがついた質問を見る

  • VBA

    1906questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

  • Excel

    1637questions

    Excelは、マイクロソフト社が開発しているデータ集計や分析を行う表計算ソフトの一つです。文書作成や表計算、資料作成などの多彩な機能を備えており、統合パッケージであるMicrosoft Officeに含まれています。