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 -
引用なし
パスワード
   ▼たろう さん：

もしかしてデータは１行目からだったでしょうか？
それと、実際の出来上がりは罫線つきの図表のような姿なんですね。
アップしたものは、とりあえずただの文字の羅列です。
系統そのものが正しく表示されるかどうかというポイントで確認してください。
【73516】Re:コードを整理したい
発言  たろう  - 13/1/17(木) 15:29 -
引用なし
パスワード
   ▼UO3 さん：
素早い返信ありがとうございます。


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

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

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

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

UO3さんが提案して下さったコードに罫線などの操作を追加していけるでしょうか？
参考書片手にちまちま作っているレベルなので解読するのに時間がかかりそうです;
【73517】Re:コードを整理したい
発言  UO3  - 13/1/17(木) 16:01 -
引用なし
パスワード
   ▼たろう さん：
。
>
>UO3さんが提案して下さったコードに罫線などの操作を追加していけるでしょうか？
>参考書片手にちまちま作っているレベルなので解読するのに時間がかかりそうです;

はい。

体系そのものがＯＫであれば、あとは、これをもとに図に仕立て上げるだけですので。
内容的にＯＫだったかどうかの確認をお願いします。
【73518】Re:コードを整理したい
発言  たろう  - 13/1/17(木) 16:24 -
引用なし
パスワード
   ▼UO3 さん：

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

ＯＫです。現状文字だけであれば希望通りに動いてくれています。
【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のデータが１行目からあるのなら

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