[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『一覧表の編集方法』（blue allow）
こんばんは。はじめまして。
エクセルについて、皆様のお知恵を頂きたく質問させて頂きます。
A B C D
100004 ●●● 池田泉州 ○○支店
100004 ●●● 三井住友 ○○支店
100004 ●●● 三菱東京ＵＦＪ ××支店
100004 ●●● 池田泉州 ××支店
100004 ●●● 三井住友信託 △△支店
100004 ●●● 池田泉州 △△支店
100004 ●●● 池田泉州 ◇◇支店
100004 ●●● 大阪北部 ◇◇支店
100004 ●●● 大阪北部
100004 ●●● 北おおさか
100004 ●●● 北おおさか
100005 ▼▼▼ みなと
100005 ▼▼▼ みなと
100005 ▼▼▼ みなと
100005 ▼▼▼ 三井住友
100005 ▼▼▼ 三井住友
100005 ▼▼▼ 三井住友
上記の様に縦に並んでいるデータをAのNoごとに横に一覧表を作成する事は
可能でしょうか？色々悩んでやってみたものの上手くいかずに困っております。何か良い関数はございますでしょうか？
みなさま、よろしくお願い致します。
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
関数でなくてVBAでの処理でも、いいですか？
>AのNoごとに横に一覧表を作成
どのようにしたいか、AのNoである「100004」の場合で説明してください。 別シートに作成したいのですか？ どの列、どの行が、はっきりわかる形で説明願います。
（マリオ） 2017/03/27(月) 19:39
ご返答ありがとうございます。
VBAでも大丈夫です。
A B C D E F G
100004 ●●● 池田泉州 ○○支店 三井住友 ○○支店
G H I
三菱東京ＵＦＪ ××支店 池田泉州
J K L M N O P Q R
××支店 三井住友信託 △△支店 池田泉州 △△支店 池田泉州 ◇◇支店 大阪北部 ◇◇支店
といった形で横にNoで同一のものを続けて表示をさせたいです。
シートについては、別シートでの作成を考えております。
よろしくお願い致します。
（blue allow） 2017/03/27(月) 19:52
>blue allow さん
■手順
(1)エクセルファイル（拡張子：xlsm）を新規作成
(2)「Sheet1」「Sheet2」の2シートを作成
(3)Module1を作成して、下記の「Postingプロシージャ」
をコピペ
(4)「Sheet1」に下記の例のように、転記元データを作成
(5)「Sheet1」のデータは、A列をキーとして、
★並べ替えを済ませておく。
(6)「Postingプロシージャ」を実行してください
(7)「Sheet1」の転記元データが、下記のような場合は、
転記先シート「Sheet2」は、下記のようになります。
★なお、「転記元データの最終行」は、Sheet1の「A列」で判定しています。
〓〓〓〓〓 Module1 〓〓〓〓〓 Option Explicit
Sub Posting() Dim fr As Long, x As Variant Dim c As Long, k As Long, max As Long, i As Long
With ThisWorkbook.Sheets("Sheet1")
fr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
x = .Range("A1:D" & fr).Value
End With
ReDim y(1 To fr, 1 To 4): c = 1: k = 2: max = 4
For i = 1 To fr - 1
If k = 2 Then
y(c, 1) = x(i, 1): y(c, 2) = x(i, 2)
End If
k = k + 2
If k > max Then
max = k
ReDim Preserve y(1 To fr, 1 To max)
End If
y(c, k - 1) = x(i, 3): y(c, k) = x(i, 4)
If x(i, 1) <> x(i + 1, 1) Then
c = c + 1: k = 2
End If
Next i
With ThisWorkbook.Sheets("Sheet2")
.UsedRange.Clear
.Range("A1").Resize(c - 1, UBound(y, 2)).Value = y
.Cells.ColumnWidth = 2.13
.UsedRange.Columns.AutoFit
End With
End Sub
〓〓〓〓〓 Sheet1 〓〓〓〓〓
|[A] |[B] |[C] |[D]
[1] |100004|●●●|池田泉州 |○○支店
[2] |100004|●●●|三井住友 |○○支店
[3] |100004|●●●|三菱東京ＵＦＪ|××支店
[4] |100004|●●●|池田泉州 |××支店
[5] |100004|●●●|三井住友信託 |△△支店
[6] |100004|●●●|池田泉州 |△△支店
[7] |100004|●●●|池田泉州 |◇◇支店
[8] |100004|●●●|大阪北部 |◇◇支店
[9] |100004|●●●|大阪北部 |
[10]|100004|●●●|北おおさか |
[11]|100004|●●●|北おおさか |
[12]|100005|▼▼▼|みなと |
[13]|100005|▼▼▼|みなと |
[14]|100005|▼▼▼|みなと |
[15]|100005|▼▼▼|三井住友 |
[16]|100005|▼▼▼|三井住友 |
[17]|100005|▼▼▼|三井住友 |
〓〓〓〓〓 Sheet2 〓〓〓〓〓
|[A] |[B]
[1]|100004|●●●
[2]|100005|▼▼▼
=============================================
|[C] |[D] |[E] |[F]
[1]|池田泉州|○○支店|三井住友|○○支店
[2]|みなと | |みなと |
=============================================
|[G] |[H] |[I] |[J]
[1]|三菱東京ＵＦＪ|××支店|池田泉州|××支店
[2]|みなと | |三井住友|
=============================================
|[K] |[L] |[M] |[N]
[1]|三井住友信託|△△支店|池田泉州|△△支店
[2]|三井住友 | |三井住友|
=============================================
|[O] |[P] |[Q] |[R]
[1]|池田泉州|◇◇支店|大阪北部|◇◇支店
[2]| | | |
=============================================
|[S] |[T]|[U] |[V]
[1]|大阪北部| |北おおさか|
[2]| | | |
=============================================
|[W] |[X]
[1]|北おおさか|
[2]| |
=============================================
〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓 ・上記のVBAコードで、やりたいことは、すべて出来ていますか？ ・「Sheet1」のD列が、「空白」のとき、「Sheet2」で、列を左に詰めますか？ ・「Sheet2」の1行目に、タイトル行を設けますか？設けるとしたら、どんなタイトルにしますか？ ・ｺｰﾄﾞの解説は、いりませんか？
（マリオ） 2017/03/28(火) 08:49
おはようございます。
早速ありがとうございます！！
試してみます！
・「Sheet1」のD列が、「空白」のとき、「Sheet2」で、列を左に詰めますか？
⇒詰める形にしたいです。
・「Sheet2」の1行目に、タイトル行を設けますか？設けるとしたら、どんなタイトルにしますか？
⇒タイトルは無でいこうと考えております。
・ｺｰﾄﾞの解説は、いりませんか？
⇒頂けますと大変助かります。
本当にいろいろとありがとうございます。
感謝致します。
（blue allow） 2017/03/28(火) 09:13
「posting2」は、詰める形にしております。
〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓 'Sheet1のD列が、空白ならSheet2で列を詰めるバージョン
Sub Posting2() Dim fr As Long, x As Variant Dim c As Long, k As Long, max As Long, i As Long
With ThisWorkbook.Sheets("Sheet1")
'Sheet1のA列最終行に、「1」を足した値をfrとする
fr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
'Sheet1のセル範囲（2次元配列）をVariat型のxに格納
x = .Range("A1:D" & fr).Value
End With
'-------------------------------------------- '(1) Sheet2に書き込むデータ(2次元配列：y) ' 1次元目のIndex番号（最大値）は、 ' 十分大きな値「fr」にしておく
'(2) 2次元目のIndex番号は、仮に「1〜4」に設定し、 ' 後ほど、「ReDim Preserve」で、 ' 2次元目のIndex番号(最大値）を変更する
'(3) 1次元目は、セルの「行」に対応したIndex番号 ' 2次元目は、セルの「列」に対応したIndex番号 ' 括弧内のカンマの左側が、1次元目（1 To fr）
'(4) y配列は、Sheet2に書込み予定のデータである ' 一方、x配列は、Sheet1の転記元データである
ReDim y(1 To fr, 1 To 4) '--------------------------------------------
c = 1 '初期値：y配列の1次元目（行） k = 2 '初期値 max = 4 '初期値
For i = 1 To fr - 1
'k=2のときは、y配列で、3列目以降のデータが格納されて
'いないときである。
If k = 2 Then
'右辺：Sheet2に記述するA列データ
'左辺：Sheet1にA列にあるデータ
y(c, 1) = x(i, 1)
'右辺：Sheet2に記述するB列データ
'左辺：Sheet1にB列にあるデータ
y(c, 2) = x(i, 2)
End If
'------------------------------------------
If Trim(x(i, 4)) = "" Then 'Sheet1のD列が空白なら
k = k + 1 '列数を1つ増やす
Else
k = k + 2 '列数を2つ増やす
End If
If k > max Then 'kがmaxを越えたなら
max = k'maxの値をkに変更する
'y配列の2次元目のIndex番号（最大値）を変更する
ReDim Preserve y(1 To fr, 1 To max)
End If
'Sheet1のD列が空白なら、x配列（右辺:Sheet1のデータ）
'をy配列（左辺:Sheet2に書込み予定のデータ）に格納
If Trim(x(i, 4)) = "" Then
y(c, k) = x(i, 3) 'Sheet1のC列データのみを格納
Else
y(c, k - 1) = x(i, 3) 'Sheet1のC列データを格納
y(c, k) = x(i, 4) 'Sheet1のD列データを格納
End If
'-------------------------------------------
If x(i, 1) <> x(i + 1, 1) Then'Sheet1のA列の内容が異なるなら
c = c + 1 'cに「1」を足す
k = 2 'リセットする
End If
Next i
With ThisWorkbook.Sheets("Sheet2")
.UsedRange.Clear '使用セルのみ、、「値、書式」を削除
'Sheet2に、2次元配列yのデータを書き込む
.Range("A1").Resize(c - 1, UBound(y, 2)).Value = y
.Cells.ColumnWidth = 2.13 'セルの幅を「2.13」にする
.UsedRange.Columns.AutoFit 'セル幅を自動調整
End With
End Sub
〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
（マリオ） 2017/03/28(火) 10:23
Dim c As Range, r As Range
ActiveSheet.Copy after:=ActiveSheet
Range("A1:B" & Rows.Count).RemoveDuplicates Columns:=Array(1, 2)
Range("C:D").ClearContents
For Each c In ActiveSheet.Previous.Range("A:A").Cells.SpecialCells(xlCellTypeConstants)
Set r = Range("A:A").Find(c.Value, , xlValues, xlWhole)
Cells(r.Row, Columns.Count).End(xlToLeft).Offset(, 1).Resize(, 2).Value = c.Offset(, 2).Resize(, 2).Value
Next c
End Sub
（mm） 2017/03/28(火) 13:12
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.