Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


1554 / 13644 ツリー ←次へ | 前へ→

【73512】コードを整理したい たろう 13/1/17(木) 11:45 質問[未読]
【73513】Re:コードを整理したい UO3 13/1/17(木) 12:14 発言[未読]
【73514】Re:コードを整理したい UO3 13/1/17(木) 12:20 発言[未読]
【73516】Re:コードを整理したい たろう 13/1/17(木) 15:29 発言[未読]
【73517】Re:コードを整理したい UO3 13/1/17(木) 16:01 発言[未読]
【73518】Re:コードを整理したい たろう 13/1/17(木) 16:24 発言[未読]
【73519】Re:コードを整理したい UO3 13/1/17(木) 19:53 発言[未読]
【73520】Re:コードを整理したい UO3 13/1/17(木) 20:30 発言[未読]
【73527】Re:コードを整理したい たろう 13/1/18(金) 10:38 発言[未読]
【73528】Re:コードを整理したい UO3 13/1/18(金) 10:46 発言[未読]
【73529】Re:コードを整理したい たろう 13/1/18(金) 11:07 発言[未読]
【73530】Re:コードを整理したい UO3 13/1/18(金) 14:37 発言[未読]
【73557】Re:コードを整理したい たろう 13/1/21(月) 10:22 お礼[未読]

【73512】コードを整理したい
質問  たろう  - 13/1/17(木) 11:45 -

引用なし
パスワード
   先週Excel4.0マクロの件でお世話になった者です。
中身は見れたもののコードの作りが今と違うのでさっぱり意味がわからず
結局自作しようということになったのですが行き詰まってしまったので
何かいい方法がないかと質問させてもらうことにしました。

一覧表から家系図のような表に変換するマクロを
作っているのですが、あまりにもコードが長くなるばかりで拡張性もなく
整理したいのですが何かいい方法はないでしょうか。

今作っているのは

1 A
2 B
1 C
2 D
3 E
2 F

みたいに1〜3に当てはめられたデータを下のように

1  2 3
A B 
C D E
  F

と列ごとに並び替えるマクロなんですが、
自分が作ったコードだとこれに4列目、5列目と増えることになると
肥大するばかりでなにがなんだかわからない状況になってしまいます。
これをもっとすっきり何列増えても対応するようなコードに整理したい
のですが何かいい方法はないでしょうか??

説明がうまくできてないと思うのでここまで作ったコードを乗せておきます。
1〜3までならこのコードでうまくいきます。

A列に1〜3の数字を入れると機能します。

  Dim i As Integer, u As Integer
  i = 2
  u = 8
  Do While Cells(i, 1).Value <> ""
    If Cells(i, 1).Value - Cells(i - 1, 1).Value = 0 Then
      If Cells(i, 1).Value = 1 Then
      Range(Cells(u + 1, 4), Cells(u + 6, 4)).Borders(xlEdgeBottom).LineStyle = xlContinuous
      Range(Cells(u + 1, 4), Cells(u + 6, 4)).Borders(xlEdgeLeft).LineStyle = xlContinuous
      Range(Cells(u + 6, 5), Cells(u + 10, 5)).BorderAround LineStyle:=xlContinuous
      Cells(u + 6, 5).Value = Cells(i, 1).Value
      ElseIf Cells(i, 1).Value = 2 Then
      Range(Cells(u + 1, 4), Cells(u + 6, 4)).Borders(xlEdgeLeft).LineStyle = xlContinuous
      Range(Cells(u + 1, 7), Cells(u + 6, 7)).Borders(xlEdgeBottom).LineStyle = xlContinuous
      Range(Cells(u + 1, 7), Cells(u + 6, 7)).Borders(xlEdgeLeft).LineStyle = xlContinuous
      Range(Cells(u + 6, 8), Cells(u + 10, 8)).BorderAround LineStyle:=xlContinuous
      Cells(u + 6, 8).Value = Cells(i, 1).Value
      ElseIf Cells(i, 1).Value = 3 Then
      Range(Cells(u + 1, 4), Cells(u + 6, 4)).Borders(xlEdgeLeft).LineStyle = xlContinuous
      Range(Cells(u + 1, 7), Cells(u + 6, 7)).Borders(xlEdgeLeft).LineStyle = xlContinuous
      Range(Cells(u + 1, 10), Cells(u + 6, 10)).Borders(xlEdgeBottom).LineStyle = xlContinuous
      Range(Cells(u + 1, 10), Cells(u + 6, 10)).Borders(xlEdgeLeft).LineStyle = xlContinuous
      Range(Cells(u + 6, 11), Cells(u + 10, 11)).BorderAround LineStyle:=xlContinuous
      Cells(u + 6, 11).Value = Cells(i, 1).Value
      End If
      u = u + 6
    ElseIf Cells(i, 1).Value - Cells(i - 1, 1).Value = 1 Then
      If Cells(i, 1).Value = 2 Then
      Range(Cells(u, 6), Cells(u, 7)).Borders(xlEdgeBottom).LineStyle = xlContinuous
      Range(Cells(u, 8), Cells(u + 4, 8)).BorderAround LineStyle:=xlContinuous
      Cells(u, 8).Value = Cells(i, 1).Value
      ElseIf Cells(i, 1).Value = 3 Then
      Range(Cells(u, 9), Cells(u, 10)).Borders(xlEdgeBottom).LineStyle = xlContinuous
      Range(Cells(u, 11), Cells(u + 4, 11)).BorderAround LineStyle:=xlContinuous
      Cells(u, 11).Value = Cells(i, 1).Value
      End If
    ElseIf Cells(i, 1).Value - Cells(i - 1, 1).Value = -1 Then
      If Cells(i, 1).Value = 1 Then
      Range(Cells(u + 1, 4), Cells(u + 6, 4)).Borders(xlEdgeBottom).LineStyle = xlContinuous
      Range(Cells(u + 1, 4), Cells(u + 6, 4)).Borders(xlEdgeLeft).LineStyle = xlContinuous
      Range(Cells(u + 6, 5), Cells(u + 10, 5)).BorderAround LineStyle:=xlContinuous
      Cells(u + 6, 5).Value = Cells(i, 1).Value
      ElseIf Cells(i, 1).Value = 2 Then
      Range(Cells(u + 1, 4), Cells(u + 6, 4)).Borders(xlEdgeLeft).LineStyle = xlContinuous
      Range(Cells(u + 1, 7), Cells(u + 6, 7)).Borders(xlEdgeBottom).LineStyle = xlContinuous
      Range(Cells(u + 1, 7), Cells(u + 6, 7)).Borders(xlEdgeLeft).LineStyle = xlContinuous
      Range(Cells(u + 6, 8), Cells(u + 10, 8)).BorderAround LineStyle:=xlContinuous
      Cells(u + 6, 8).Value = Cells(i, 1).Value
      End If
      u = u + 6
    ElseIf Cells(i, 1).Value - Cells(i - 1, 1).Value = -2 Then
      If Cells(u, 8).Value = "" Then
      Range(Cells(u + 1, 6), Cells(u + 1, 7)).AutoFill Destination:=Range(Cells(u - 5, 6), Cells(u + 1, 7)), Type:=xlFillDefault
      End If
      Range(Cells(u + 1, 4), Cells(u + 6, 4)).Borders(xlEdgeBottom).LineStyle = xlContinuous
      Range(Cells(u + 1, 4), Cells(u + 6, 4)).Borders(xlEdgeLeft).LineStyle = xlContinuous
      Range(Cells(u + 6, 5), Cells(u + 10, 5)).BorderAround LineStyle:=xlContinuous
      Cells(u + 6, 5).Value = Cells(i, 1).Value
      u = u + 6
    End If
    i = i + 1
  Loop
  ActiveCell.Offset(1, 0).Select

【73513】Re:コードを整理したい
発言  UO3  - 13/1/17(木) 12:14 -

引用なし
パスワード
   ▼たろう さん:

こんにちは

以下のようなことですか?

Sub Sample()
  Dim lMax As Long
  Dim v() As String
  Dim c As Range
  Dim k As Long
  Dim oLvl As Long
  
  With Sheets("Sheet1")    '元シート
    With .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
      lMax = WorksheetFunction.Max(.Columns(1))
      ReDim v(1 To .Rows.Count, 1 To lMax)
      
      For Each c In .Columns(1).Cells
        If c.Value = 1 Or c.Value <= oLvl Then k = k + 1
        v(k, c.Value) = c.Offset(, 1).Value
        oLvl = c.Value
      Next
    End With
  End With
      
  With Sheets("Sheet2")    '転記シート
    .UsedRange.ClearContents
    .Range("A1").Resize(k, UBound(v, 2)).Value = v
    .Select
  End With
  
  MsgBox "転記完了です"
  
End Sub

【73514】Re:コードを整理したい
発言  UO3  - 13/1/17(木) 12:20 -

引用なし
パスワード
   ▼たろう さん:

もしかしてデータは1行目からだったでしょうか?
それと、実際の出来上がりは罫線つきの図表のような姿なんですね。
アップしたものは、とりあえずただの文字の羅列です。
系統そのものが正しく表示されるかどうかというポイントで確認してください。

【73516】Re:コードを整理したい
発言  たろう  - 13/1/17(木) 15:29 -

引用なし
パスワード
   ▼UO3 さん:
素早い返信ありがとうございます。


>もしかしてデータは1行目からだったでしょうか?

そうなんですが、1行目は必ず「1」と決まっているので
作業は2行目からとしてあります。

>それと、実際の出来上がりは罫線つきの図表のような姿なんですね。

建設工事等で使われる施工体系図というやつです。
私もUO3さんが提示してくれたような形(とはいってもあんな簡潔なコードでは
ありませんが)から罫線の操作などを足していったんですが、
罫線の引き方が似ているけど同じ1でも一つ前の数字によって微妙に違って
きたりするので追加していったらあんな惨状になってしまいました。
これが4.5と増えていったらどうにも手に負えなくなってしまうのです。

UO3さんが提案して下さったコードに罫線などの操作を追加していけるでしょうか?
参考書片手にちまちま作っているレベルなので解読するのに時間がかかりそうです;

【73517】Re:コードを整理したい
発言  UO3  - 13/1/17(木) 16:01 -

引用なし
パスワード
   ▼たろう さん:

>
>UO3さんが提案して下さったコードに罫線などの操作を追加していけるでしょうか?
>参考書片手にちまちま作っているレベルなので解読するのに時間がかかりそうです;

はい。

体系そのものがOKであれば、あとは、これをもとに図に仕立て上げるだけですので。
内容的にOKだったかどうかの確認をお願いします。

【73518】Re:コードを整理したい
発言  たろう  - 13/1/17(木) 16:24 -

引用なし
パスワード
   ▼UO3 さん:

>体系そのものがOKであれば、あとは、これをもとに図に仕立て上げるだけですので。
>内容的にOKだったかどうかの確認をお願いします。

OKです。現状文字だけであれば希望通りに動いてくれています。

【73519】Re:コードを整理したい
発言  UO3  - 13/1/17(木) 19:53 -

引用なし
パスワード
   ▼たろう さん:

ではアップ済みのものをベースに図にしたてあげたものです。
図は、SHeet2に作成します。

Sub Sample2()

  Const stFlow As String = "D9"
  Const stCell As String = "E14"
  
  Dim lMax As Long
  Dim v() As String
  Dim joinR() As Range
  Dim c As Range
  Dim k As Long
  Dim oLvl As Long
  Dim myR As Range
  Dim i As Long
  Dim j As Long
  Dim flg As Boolean
  
  With Sheets("Sheet1")    '元シート
    With .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
      lMax = WorksheetFunction.Max(.Columns(1))
      ReDim v(1 To .Rows.Count, 1 To lMax)
      ReDim joinR(1 To lMax)
      For Each c In .Columns(1).Cells
        If c.Value = 1 Or c.Value <= oLvl Then k = k + 1
        v(k, c.Value) = c.Offset(, 1).Value
        oLvl = c.Value
      Next
    End With
  End With
      
  With Sheets("Sheet2")    '転記シート
    With .UsedRange
      .Borders.LineStyle = xlNone
      .ClearContents
      .MergeCells = False
    End With
    
    Set myR = .Range(stCell)
    Set joinR(1) = .Range(stFlow)
    
    For i = 1 To k
      For j = 1 To UBound(v, 2)
        If Len(v(i, j)) > 0 Then
          myR.Resize(5).Merge
          myR.Value = v(i, j)
          With myR.Resize(5)
            .Borders.LineStyle = xlContinuous
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
          End With
          flg = False
          If j = 1 Then
            flg = True
          ElseIf Len(v(i, j - 1)) = 0 Then
            flg = True
          End If
          
          If flg Then
            With .Range(joinR(j), myR.Offset(, -1))
              .Borders(xlEdgeLeft).LineStyle = xlContinuous
              .Borders(xlEdgeBottom).LineStyle = xlContinuous
            End With
          Else
            myR.Offset(, -2).Resize(, 2).Borders(xlEdgeBottom).LineStyle = xlContinuous
          End If
          Set joinR(j) = myR.Offset(, -1).Offset(1)
        End If
        Set myR = myR.Offset(, 3)
      Next
      
      Set myR = myR.Offset(6).EntireRow.Cells(.Range(stCell).Column)
      
    Next
      
    .Select
    
  End With
  
  MsgBox "転記完了です"
  
End Sub

【73520】Re:コードを整理したい
発言  UO3  - 13/1/17(木) 20:30 -

引用なし
パスワード
   ▼たろう さん:

↑のコードですがSheet1のデータが1行目からあるのなら

With .Range("A2", .Range("A" & .Rows.Count).End(xlUp))

これを

With .Range("A1", .Range("A" & .Rows.Count).End(xlUp))

にかえてくださいね。

【73527】Re:コードを整理したい
発言  たろう  - 13/1/18(金) 10:38 -

引用なし
パスワード
   ▼UO3 さん:
ありがとうございます
確認してみましたが
普通にやると

v(k, c.Value) = c.Offset(, 1).Value

インデックスが有効ではありませんエラー

A2をA1に変えてみたところ
転記完了ですまででましたがデバッグしたところ
なぜか転記シートのIFの中に一回も入っていかなかったため
何も転記されないまま終了という感じです

Sheet1のA列に元データでいいんですよね?
何か間違ったのかもしれません

【73528】Re:コードを整理したい
発言  UO3  - 13/1/18(金) 10:46 -

引用なし
パスワード
   ▼たろう さん:

不思議ですね。
まず、Sheet1 の A列、B列の1行目から 最初にアップされた

1    A
2    B
1    C
2    D
3    E
2    F

このデータにして試していただけませんか?

【73529】Re:コードを整理したい
発言  たろう  - 13/1/18(金) 11:07 -

引用なし
パスワード
   ▼UO3 さん:
すいませんアルファベット入れてませんでした。
しかしA1なら問題ないのですがA2のままだとエラーが出ます
何がいけないんでしょう??

【73530】Re:コードを整理したい
発言  UO3  - 13/1/18(金) 14:37 -

引用なし
パスワード
   ▼たろう さん:

こんにちは
A1がレベル1ですよね。
A2から処理始めると、レベル1がない状態で実行されますから
コード的には不都合になります。

当初は 1行目がタイトル行で、データが2行目からはじまるという想定のコードでしたので
データの最初ということで A2 だったんですが、1行目がデータであれば A1 から処理必要です。

【73557】Re:コードを整理したい
お礼  たろう  - 13/1/21(月) 10:22 -

引用なし
パスワード
   ▼UO3 さん:

了解です。
ありがとうございました。
あとはなんとか自分でやってみます。

1554 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free