Excel2000での初歩表計算

質問

いつも御世話になっております。

今回はExcelを用いた初歩的な表計算で躓き投稿をさせて頂きました。

早速ですが、具体的な例を挙げます。
1 ------------------
2 A社 B社 C社
3 100 500 200
4 200 600 300
5 300 700 450
6 400 150 510
7 -----------------
この様に順不同で羅列された数字郡を
並べ替えたいのですが、この"縦列を崩さずに"並べ変えるには
どうすれば良いのでしょうか。
今までは列毎に色付けしてから
1列にまとめてデータ＞並べ替えしてから手入力で列を復元させてました。

具体的にはこう言う感じにしたいのですが、、、
1 ------------------
2 A社 B社 C社
3 100
4 150
5 200 200
6 300 300
7 400
8 450
9 500
10 510
11 600
12 700
------------------
こんな感じで重複してれば同じ位置に、
複数の列を関連させて並べ替えさせたいのです。

このデータの処理が出来れば
使用ソフトはエクセルでなくても構いません。

聊か説明が解り難かったかも知れませんが、
補足要求や御助言頂ければ御願い致します。

回答No.6

Wendy02 · ベストアンサー

こんにちは。

VBAですと、こんなところでしょうかしらね。
昨日、できていたのですが、朝、見直しまし、オプションをつけました。

データは、A列から始まることは条件にしても、行の最初が決まっていないこと、タイトル行があるなしを想定しています。また、あたりまえのことですが、列の許す限りは、一応は、並べ替えはしてくれます。処理スピードも、そこそこに走ってくれます。

また、万が一、上書きや列が127行を超える予定がある場合は、ご相談ください。

'<標準モジュール>
Sub SortWithColumn()
　'列付きの並び替え
　Dim rng As Range, c As Range
　Dim i As Long, k As Long, n As Long
　Dim myTitle As Variant, myArray As Variant
　Dim Rfirst As Long, Cfirst As Long, titleFlg As Byte
　Dim myData As Double
　Application.ScreenUpdating = False
　'A列にデータがあれば、その範囲を取得
　With Range("A65536").End(xlUp).CurrentRegion
　　'データの最初の行は？
　　Rfirst = .Cells(1, 1).Row
　　'タイトル行のチェック
　　If VarType(.Cells(1, 1)) = vbDouble Then
　　　　Rfirst = Rfirst - 1
　　　　titleFlg = 1 'タイトルなし
　　 Else
　　　　myTitle = .Rows(1).Value　'タイトルは配列で取得
　　End If
　　'書き出しの列は、そのデータから2列離れた列
　　Cfirst = .Columns.Count + 2
　　'列の幅のチェック/もし、このメッセージが出たら、現行では終了
　　If Cfirst > 127 Then MsgBox "列が許容範囲を超えています。", 64: Exit Sub
　　Set rng = .Offset(1 - titleFlg).Resize(.Rows.Count - 1 + titleFlg)
　End With
　ReDim myArray(1, rng.Count - 1)
　For Each c In rng
　　myArray(0, i) = c.Value
　　myArray(1, i) = c.Column
　　i = i + 1
　Next c
　'ソートプログラム
　mySort myArray
　'書き出しの最初の行,書き出しの最初の列
　k = Rfirst: Cfirst = Cfirst
　'タイトルの書き出し
　If IsArray(myTitle) Then
　Cells(k, Cfirst + 1).Resize(, rng.Columns.Count).Value _
　= myTitle
　End If
　'
　For n = LBound(myArray, 2) To UBound(myArray, 2)
　　If myData <> myArray(0, n) Then
　　　k = k + 1
　　　Cells(k, Cfirst + myArray(1, n)).Value = myArray(0, n)
　　　Else
　　　Cells(k, Cfirst + myArray(1, n)).Value = myArray(0, n)
　　End If
　　If n < UBound(myArray, 2) - 1 Then
　　　myData = myArray(0, n)
　　End If
　Next n
　Application.ScreenUpdating = True
End Sub
Private Sub mySort(ar)
　'2次元ソート
　Dim u As Long
　Dim i As Long
　Dim j As Long
　Dim t1 As Long, t2 As Long
　u = UBound(ar, 2)
　i = LBound(ar, 2)
　Do While i < u
　　j = u
　　Do While j > i
　　　If ar(0, j) < ar(0, i) Then '昇順
　　　　t1 = ar(0, j)
　　　　t2 = ar(1, j)
　　　　ar(0, j) = ar(0, i)
　　　　ar(1, j) = ar(1, i)
　　　　ar(0, i) = t1
　　　　ar(1, i) = t2
　　　End If
　　　j = j - 1
　　Loop
　　i = i + 1
　Loop
End Sub

お礼

正に私が思い描いた処理が出来ました。
VBAについては初心者だったのですが、いい勉強になりました。
有難う御座いました。

回答No.8

Wendy02

#6 のWendyです。
文章の訂正です。

×「また、万が一、上書きや列が127『行』を超える予定がある場合は、ご相談ください。」

○「また、万が一、上書きや列が127列を超える予定がある場合は、ご相談ください。」

つまり、上書きはしていないので、列の間を含めて、256の半分を超えてしまうと出力できなくなります。その場合は、シートを替えなくてはなりません。

回答No.7

HAL2010

仕事の帰り際に見て、気になって自宅でVBA組んで見ました。
>Excel2000での初歩表計算
すでに、同様の解答が出てますが、結構面倒ですね＾＾；
まあ、あんまりスマートではありませんが、質問で例にあげられていたパターンは依頼どおり設定できました。

Sub Macro1()
Dim intI As Integer
Dim intJ As Integer
Dim intK As Integer
Dim intL As Integer
Dim intMax As Integer
Dim MaxData As Integer
Dim FinF(3) As Integer

'A、B、C列をそれぞれソート
Range("A:A").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin
Range("B:B").Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin
Range("C:C").Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin

'３列がすべて空白になるまで実行(要素数把握)
Do
intI = intI + 1
If Cells(intI, 1) = "" And _
Cells(intI, 2) = "" And _
Cells(intI, 2) = "" Then
'すべて初期値なら繰り返し処理終了
Exit Do
End If
Loop

'最大行数退避
intMax = intI - 1
ReDim intData(intMax, 3) As Integer

'要素をすべて退避
For intJ = 1 To intMax
intData(intJ, 1) = Cells(intJ, 1) 'A
intData(intJ, 2) = Cells(intJ, 2) 'B
intData(intJ, 3) = Cells(intJ, 3) 'C
Next intJ

'最大値+1を退避
If intData(intMax, 1) >= intData(intMax, 2) And _
intData(intMax, 1) >= intData(intMax, 2) Then
MaxData = intData(intMax, 1) + 1
ElseIf intData(intMax, 2) >= intData(intMax, 1) And _
intData(intMax, 2) >= intData(intMax, 3) Then
MaxData = intData(intMax, 2) + 1
Else
MaxData = intData(intMax, 3) + 1
End If

'初期値設定
intI = 1
intJ = 1
intK = 1
'各々のセルに設定
Do
intL = intL + 1
If intData(intI, 1) < intData(intJ, 2) And _
intData(intI, 1) < intData(intK, 3) Then
Cells(intL, 1) = intData(intI, 1)
Cells(intL, 2) = ""
Cells(intL, 3) = ""
intI = intI + 1

ElseIf intData(intJ, 2) < intData(intI, 1) And _
intData(intJ, 2) < intData(intK, 3) Then
Cells(intL, 1) = ""
Cells(intL, 2) = intData(intJ, 2)
Cells(intL, 3) = ""
intJ = intJ + 1

ElseIf intData(intK, 3) < intData(intI, 1) And _
intData(intK, 3) < intData(intJ, 2) Then
Cells(intL, 1) = ""
Cells(intL, 2) = ""
Cells(intL, 3) = intData(intK, 3)
intK = intK + 1

ElseIf intData(intI, 1) = intData(intJ, 2) And _
intData(intI, 1) < intData(intK, 3) Then
Cells(intL, 1) = intData(intI, 1)
Cells(intL, 2) = intData(intJ, 2)
Cells(intL, 3) = ""
intI = intI + 1
intJ = intJ + 1

ElseIf intData(intI, 1) = intData(intK, 3) And _
intData(intI, 1) < intData(intJ, 2) Then
Cells(intL, 1) = intData(intI, 1)
Cells(intL, 2) = ""
Cells(intL, 3) = intData(intK, 3)
intI = intI + 1
intK = intK + 1

ElseIf intData(intJ, 2) = intData(intK, 3) And _
intData(intJ, 2) < intData(intI, 1) Then
Cells(intL, 1) = ""
Cells(intL, 2) = intData(intJ, 2)
Cells(intL, 3) = intData(intK, 3)
intJ = intJ + 1
intK = intK + 1

Else
Cells(intL, 1) = intData(intI, 1)
Cells(intL, 2) = intData(intJ, 2)
Cells(intL, 3) = intData(intK, 3)
intI = intI + 1
intJ = intJ + 1
intK = intK + 1

End If

If intI > intMax Then
FinF(1) = 1
intI = intMax
intData(intI, 1) = MaxData
End If

If intJ > intMax Then
FinF(2) = 1
intJ = intMax
intData(intJ, 2) = MaxData
End If

If intK > intMax Then
FinF(3) = 1
intK = intMax
intData(intK, 3) = MaxData
End If

If FinF(1) = 1 And FinF(2) = 1 And FinF(3) = 1 Then
Exit Do
End If
Loop

End Sub

お礼

どのコマンドでどの様な処理をしようとしているのは
大体雰囲気は解ったのですが、まだまだ勉強不足の様で、、
有難う御座いました。

回答No.5

BLUEPIXY

人に振って終わりだとあんまりなので、一応作ってみました。
全部ＶＢＡで作った方が、スピード的に有利だと思いますが、
参考ＵＲＬ＃３の
mySmallというような順序づけを飛ばさない関数を使うと結構簡単です。
処理前のデータを残して
Ａ８に
=IF(COUNTIF(A$3:A$6,mySmall($A$3:$C$6,ROWS(A$2:A2))),mySmall($A$3:$C$6,ROWS(A$2:A2)),"")
の式を入れて横に引っ張って縦に引っ張るとそういう形になります。
後は、できた部分をコピーして値で貼り付けで完成。
惜しむらくはとても遅いということですが、
どうせなら、全部ＶＢＡで作った方が早いと思いますが、
最近作った関数の再利用ということでやってみました。

参考URL：

http://okweb.jp/kotaeru.php3?q=1478241

回答No.4

imogasi

（１）関数でも相当難しい。多分不可能。できるかどうかも未経験。
（２）VBA（俗に言うマクロ）でもそのロジック（達成するためにどういう風に理屈を組み立てるか）も難しく、相当プログラムの経験をつんだ人から出そう。
私の思いついたのは、ヒントは
（１）３社（１０社とか）の計数を全社込みで、会社列記号＋計数のレコードを作り計数＋会社列記号で昇順ソートする
（２）先頭から順に会社記号各列にセットしていく、同じ計数で数異記号は同行にセットする。行を進めない。
（３）同じ社で同じ値は下へ書き込む。書き込んだ数は覚える。各社の同じ値の最大行数を捕らえる。
（４）（３）の最大数＋１行下から（２）を繰り返す。
何でそんな面倒なことをするのというレベルではこの問題は解けません。
もっとスッキリしたロジックがあれば教えていただきたいぐらいです。
上記でわかるように、これはVBAや関数の問題でなく、どう考えて手順を組み立てれば、すっきり処理できるかという問題の方が大事でかつ先行すべきものです。プログラムコーディングはそれほど難しいわけではないでしょう。
ですからエクセルVBAで十分です。

回答No.3

Wendy02

#1 のWendy02 です。
なるほどね。分かりました。#1の回答は、「没」にしてください。どうやら、VBAが必要のようですね。

ところで、以下のようになるのですね。
C社の部分が変です。本日は、遅いので、たぶん、明日にさせてください。

元のご質問は、ソースでも確認できましたが、こちらは、全角スペースを使っています。念のため。

1　　　　　　　　　
2 A社　B社　　C社
3 100　　　　　
4　　　150　　
5 200　　　　 200
6 300　　　　 300
7 400　　　　　
8　　　　　　 450
9　　　500　　
10　　　　　　510
11　　 600　　
12　　 700　　
13

回答No.2

BLUEPIXY

各列毎に、会社を区別した色をつけそのデータを縦に並べ替える（重複するデータはその横並び）という意味なら、ＶＢＡを使わずにはできません。

多分、Wendy02さんが作ってくれると思います。

回答No.1

Wendy02

こんにちは。

私は、関数は不得意なのですが、「初歩的な表計算」とは思えません。

E2:～

=IF(COUNT($A$2:$C$5)<=COUNT($E$1:F1),"",SMALL($A$2:$C$5,COUNT($E$1:F1)+1))

F2:～
=IF(COUNTIF($A$2:$C$5,E2)<2,"",E2)

もし、三つあれば、
E2:～
=IF(COUNT($A$2:$C$5)<=COUNT($E$1:G1),"",SMALL($A$2:$C$5,COUNT($E$1:G1)+1))

F2:～
=IF(COUNTIF($A$2:$C$5,E2)<2,"",E2)

G2:～
=IF(COUNTIF($A$2:$C$5,E2)<3,"",E2)

となりますね。

もし、VBAでもよいのでしたら、そちらも考えてみたいと思います。

＞並べ替えたいのですが、この"縦列を崩さずに"並べ変えるにはどうすれば良いのでしょうか。

ということは、Excelの並び替え機能は使わずに作ることになると思います。

補足

助言頂き有難うございます。
質問での図がスペースで潰れてしまってたので、
改めて入れますと、
1-------------------
2-A社--B社--C社
3-100----------
4------150-----
5-200--200-----
6-300--300-----
7-400----------
8-----------450
9------500-----
10----------510
11-----600-----
12-----700-----
13------------------
こんな感じになります、、