[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『昇順並び替えによる移動と同じ移動を異なるシートで行いたい』(けーすけ)
状況としては、シート1にランダムで生成された100*100の数列があり、この数列を昇順で移動させます。シート2にもランダムに生成された100*100の数列があり、この数列をシート1と同じ移動の仕方で移動させることは可能でしょうか?
例えば
シート1
1 5 0 1
3 0 を 3 5 としたら
シート2では
0 7 4 0
6 4 を 6 7 となるようにしたいです。
この掲示板を使うのは初めてなので至らない点もあるかと思いますが
よろしくお願いします。
< 使用 Excel:Office365、使用 OS:Windows10 >
シート1の数値に重複はあるのでしょうか。
>この数列を昇順で移動させます。
重複がある場合、昇順並び替えのルールを教えてください。
(マナ) 2019/06/17(月) 20:38
シート1
1 5 0 1
5 0 を 5 5 としたら
シート2では、
0 7 4 0
6 4 を 6 7
それとも
0 7 4 0
6 4 を 7 6
どちらですか。
(マナ) 2019/06/17(月) 20:55
(マナ) 2019/06/17(月) 20:58
こんばんは!
方法は色々あると思いますが、、、クイックソートに乗っけて並び替えると
4 0 6 7
Option Explicit Sub てすと() Dim MyA As Variant Dim MyB As Variant Dim MyC As Variant Dim MyD As Variant Dim i As Long Dim j As Long Dim k As Long With Sheets("Sheet1") MyA = .Range("A1").CurrentRegion.Value End With With Sheets("Sheet2") MyB = .Range("A1").Resize(UBound(MyA, 1), UBound(MyA, 2)).Value End With ReDim MyC(LBound(MyA, 1) To UBound(MyA, 1) * UBound(MyA, 2), 1 To 1) ReDim MyD(LBound(MyA, 1) To UBound(MyA, 1) * UBound(MyA, 2), 1 To 1) k = 0 For i = LBound(MyA, 1) To UBound(MyA, 1) For j = LBound(MyA, 2) To UBound(MyA, 2) k = k + 1 MyC(k, 1) = MyA(i, j) Next Next k = 0 For i = LBound(MyA, 1) To UBound(MyA, 1) For j = LBound(MyA, 2) To UBound(MyA, 2) k = k + 1 MyD(k, 1) = MyB(i, j) Next Next QuickSort MyC, 1, LBound(MyC, 1), UBound(MyC, 1), MyD k = 0 For i = LBound(MyA, 1) To UBound(MyA, 1) For j = LBound(MyA, 2) To UBound(MyA, 2) k = k + 1 MyB(i, j) = MyD(k, 1) Next Next With Sheets("Sheet3") .Cells.Clear .Range("A1").Resize(UBound(MyA, 1), UBound(MyA, 2)).Value = MyB End With Erase MyA, MyB, MyC, MyD End Sub Private Sub QuickSort( _ ByRef MySAry As Variant, _ ByVal MySKey As Long, _ ByVal MySLeft As Long, _ ByVal MySRight As Long, _ ByRef MyAAry As Variant) Dim MySMid As Long Dim i As Long, j As Long, n As Long Dim MySLBound As Long, MySUBound As Long Dim MyStmp As Double Dim MyATmp As Double MySLBound = LBound(MySAry, 2) MySUBound = UBound(MySAry, 2) MySMid = MySAry((MySLeft + MySRight) \ 2, MySKey) i = MySLeft j = MySRight Do Do While MySAry(i, MySKey) < MySMid i = i + 1 Loop Do While MySAry(j, MySKey) > MySMid j = j - 1 Loop If i >= j Then Exit Do For n = MySLBound To MySUBound MyStmp = MySAry(i, n) MySAry(i, n) = MySAry(j, n) MySAry(j, n) = MyStmp MyATmp = MyAAry(i, n) MyAAry(i, n) = MyAAry(j, n) MyAAry(j, n) = MyATmp Next i = i + 1 j = j - 1 Loop If MySLeft < i - 1 Then QuickSort MySAry, MySKey, MySLeft, i - 1, MyAAry If MySRight > j + 1 Then QuickSort MySAry, MySKey, j + 1, MySRight, MyAAry End Sub
Sheetに吐き出して並び替えると
4 0 7 6
Option Explicit Sub てすと() Dim MyA As Variant Dim MyB As Variant Dim MyC As Variant Dim i As Long Dim j As Long Dim k As Long With Sheets("Sheet1") MyA = .Range("A1").CurrentRegion.Value End With With Sheets("Sheet2") MyB = .Range("A1").Resize(UBound(MyA, 1), UBound(MyA, 2)).Value End With ReDim MyC(LBound(MyA, 1) To UBound(MyA, 1) * UBound(MyA, 2), 1 To 2) k = 0 For i = LBound(MyA, 1) To UBound(MyA, 1) For j = LBound(MyA, 2) To UBound(MyA, 2) k = k + 1 MyC(k, 1) = MyA(i, j) MyC(k, 2) = MyB(i, j) Next Next Application.ScreenUpdating = False With Sheets("Sheet3") .Cells.Clear .Range("A1").Resize(UBound(MyC, 1), UBound(MyC, 2)).Value = MyC .Sort.SortFields.Add Key:=Range("A1:A" & UBound(MyC, 1)) With .Sort .SetRange Range("A1:B" & UBound(MyC, 1)) .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With MyC = .Range("A1").Resize(UBound(MyC, 1), UBound(MyC, 2)).Value k = 0 For i = LBound(MyA, 1) To UBound(MyA, 1) For j = LBound(MyA, 2) To UBound(MyA, 2) k = k + 1 MyB(i, j) = MyC(k, 2) Next Next .Cells.Clear .Range("A1").Resize(UBound(MyB, 1), UBound(MyB, 2)).Value = MyB End With Application.ScreenUpdating = True Erase MyA, MyB, MyC End Sub
こうなりました。。。。
もう寝ます。おやすみなさいzzzzzzzzzzzzzzzzzzzzz (SoulMan) 2019/06/18(火) 00:02
またマクロの使用も問題ないです。
(けーすけ) 2019/06/18(火) 09:15
Sheet1を昇順に並び替えたと同じ動作をSheet2に反映する?
こういうことだと思うけど、検証が大変そう...
Sub test() Dim a, e, i As Long, ii As Long, n As Long, t As Long, SL As Object Set SL = CreateObject("System.Collections.SortedList") With Sheets("sheet1").Cells(1).CurrentRegion a = .Value For i = 1 To UBound(a, 1) For ii = 1 To UBound(a, 2) SL(a(i, ii)) = SL(a(i, ii)) & IIf(SL(a(i, ii)) <> "", ",", "") & .Cells(i, ii).Address(0, 0) Next ii, i n = 1 For i = 0 To SL.Count - 1 For Each e In Split(SL.GetByIndex(i), ",") t = t + 1 If t > .Columns.Count Then t = 1: n = n + 1 a(n, t) = SL.GetKey(i) Next Next .Value = a End With With Sheets("sheet2").Cells(1).CurrentRegion n = 1: t = 0 For i = 0 To SL.Count - 1 For Each e In Split(SL.GetByIndex(i), ",") t = t + 1 If t > .Columns.Count Then t = 1: n = n + 1 a(n, t) = .Range(e).Value Next Next .Value = a End With End Sub
(seiya) 2019/06/18(火) 09:41
Dim mr As Long, mc As Long, i As Long, x As Long, c As Range Sheets.Add after:=Sheets("Sheet1") ActiveSheet.Name = "並替後Sheet1" Sheets.Add after:=Sheets("Sheet2") ActiveSheet.Name = "修正後Sheet2" mr = Sheets("Sheet1").Range("A1").CurrentRegion.Rows.Count mc = Sheets("Sheet1").Range("A1").CurrentRegion.Columns.Count For i = WorksheetFunction.Min(Sheets("Sheet1").Range("A1").CurrentRegion) To WorksheetFunction.Max(Sheets("Sheet1").Range("A1").CurrentRegion) For Each c In Sheets("Sheet1").Range("A1").CurrentRegion If i = c.Value Then Sheets("並替後Sheet1").Range("A1").Resize(mr, mc).Cells(x + 1).Value = i Sheets("修正後Sheet2").Range("A1").Resize(mr, mc).Cells(x + 1).Value = Sheets("Sheet2").Cells(c.Row, c.Column).Value x = x + 1 End If Next c Next i End Sub (mm) 2019/06/18(火) 13:47
あぁぁ、、一歩遅れたかぁ、、、
まぁ、、、解決されて良かったです。
ここからは番外編ということで、、わちきの趣味趣向??です。(^^;
二つ並べて並び替えちゃえばいいと思いますが、、、インデックスを連れて並び替えて
並び替わったインデックスで相手を再生するという。。趣味趣向でやってみました。
ちなみに、、↓になりました
4 0 6 7
>この掲示板を使うのは初めてなので
ここからですよぉぉぉ、、学校のいいところは(笑)
では、、では、、また、、、遊びに来てください。
Option Explicit Sub いんでっくすでもう一つにあわせちゃうぞぉぉぉシリーズ() Dim MyA As Variant Dim MyB As Variant Dim MyC As Variant Dim MyD As Variant Dim i As Long Dim j As Long Dim k As Long With Sheets("Sheet1") MyA = .Range("A1").CurrentRegion.Value End With With Sheets("Sheet2") MyB = .Range("A1").Resize(UBound(MyA, 1), UBound(MyA, 2)).Value End With ReDim MyC(LBound(MyA, 1) To UBound(MyA, 1) * UBound(MyA, 2), 1 To 3) ReDim MyD(LBound(MyA, 1) To UBound(MyA, 1), LBound(MyA, 2) To UBound(MyA, 2)) k = 0 For i = LBound(MyA, 1) To UBound(MyA, 1) For j = LBound(MyA, 2) To UBound(MyA, 2) k = k + 1 MyC(k, 1) = MyA(i, j) MyC(k, 2) = i MyC(k, 3) = j Next Next QuickSort MyC, 1, LBound(MyC, 1), UBound(MyC, 1) k = 0 For i = LBound(MyA, 1) To UBound(MyA, 1) For j = LBound(MyA, 2) To UBound(MyA, 2) k = k + 1 MyD(i, j) = MyB(MyC(k, 2), MyC(k, 3)) Next Next With Sheets("Sheet3") .Cells.Clear .Range("A1").Resize(UBound(MyA, 1), UBound(MyA, 2)).Value = MyD End With Erase MyA, MyB, MyC, MyD End Sub Private Sub QuickSort( _ ByRef MySAry As Variant, _ ByVal MySKey As Long, _ ByVal MySLeft As Long, _ ByVal MySRight As Long) Dim MySMid As Long Dim i As Long, j As Long, n As Long Dim MySLBound As Long, MySUBound As Long Dim MyStmp As Double MySLBound = LBound(MySAry, 2) MySUBound = UBound(MySAry, 2) MySMid = MySAry((MySLeft + MySRight) \ 2, MySKey) i = MySLeft j = MySRight Do Do While MySAry(i, MySKey) < MySMid i = i + 1 Loop Do While MySAry(j, MySKey) > MySMid j = j - 1 Loop If i >= j Then Exit Do For n = MySLBound To MySUBound MyStmp = MySAry(i, n) MySAry(i, n) = MySAry(j, n) MySAry(j, n) = MyStmp Next i = i + 1 j = j - 1 Loop If MySLeft < i - 1 Then QuickSort MySAry, MySKey, MySLeft, i - 1 If MySRight > j + 1 Then QuickSort MySAry, MySKey, j + 1, MySRight End Sub (SoulMan) 2019/06/18(火) 19:43
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.