[[20190617161750]]　『昇順並び替えによる移動と同じ移動を異なるシート』（けーすけ）　ページの最後に飛ぶ

『昇順並び替えによる移動と同じ移動を異なるシートで行いたい』（けーすけ）

状況としては、シート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にランダムで生成された100*100の数列があり、

シート１の数値に重複はあるのでしょうか。

＞この数列を昇順で移動させます。

重複がある場合、昇順並び替えのルールを教えてください。

（マナ） 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

コメントありがとうございます。
シート1に重複はありますが、重複した数字の区別はないものとして考えてくださってかまいません。
マナさんのシート2で言えば、6と7の順番はどちらでも大丈夫です。

またマクロの使用も問題ないです。
（けーすけ） 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

Sub main()’数列データはA1から始まる前提

    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

みなさんありがとうございました。
おかげで無事計算ができました。
（けーすけ） 2019/06/18(火) 18:34

 あぁぁ、、一歩遅れたかぁ、、、

 まぁ、、、解決されて良かったです。

 ここからは番外編ということで、、わちきの趣味趣向？？です。(^^;

 二つ並べて並び替えちゃえばいいと思いますが、、、インデックスを連れて並び替えて

 並び替わったインデックスで相手を再生するという。。趣味趣向でやってみました。

 ちなみに、、↓になりました

 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

コメント返信：

[ 一覧(最新更新順) ]

[[20190617161750]] 『昇順並び替えによる移動と同じ移動を異なるシート』（けーすけ） ページの最後に飛ぶ

[[20190617161750]]　『昇順並び替えによる移動と同じ移動を異なるシート』（けーすけ）　ページの最後に飛ぶ