Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


6333 / 13646 ツリー ←次へ | 前へ→

【45807】どのようにやるのでしょうか? KAI 07/1/14(日) 22:07 質問[未読]
【45808】Re:どのようにやるのでしょうか? KAI 07/1/14(日) 22:10 発言[未読]
【45812】Re:どのようにやるのでしょうか? Kein 07/1/14(日) 23:42 回答[未読]
【45810】Re:どのようにやるのでしょうか? ichinose 07/1/14(日) 22:56 発言[未読]
【45874】Re:どのようにやるのでしょうか? KAI 07/1/16(火) 20:51 お礼[未読]

【45807】どのようにやるのでしょうか?
質問  KAI  - 07/1/14(日) 22:07 -

引用なし
パスワード
   以下のシート(Sheet1)の場合、大きい順に(Sheet2)のA列にB4.A3.D2…と書くことはできるのでしょうか??
また、できるのならば、同得点の場合の処理もどうにかお願いします。


(Sheet1)           (Sheet2)
  A  B  C  D  E        A  B  C
1 100 123 321 566 129     1   B4
2 578 654 156 846 345  ⇒ 2   A3
3 875 659 800 124 651     3   D2
4 758 986 425 154 445     4   C3

【45808】Re:どのようにやるのでしょうか?
発言  KAI  - 07/1/14(日) 22:10 -

引用なし
パスワード
   すいません、上の(Sheet2)ずれちゃいました…

(Sheet2)
  A B C 
1 B4
2 A3
3 D2
4 C3

【45810】Re:どのようにやるのでしょうか?
発言  ichinose  - 07/1/14(日) 22:56 -

引用なし
パスワード
   ▼KAI さん:
こんばんは。
Sheet1のデータは、全て数値であるという条件です。

>以下のシート(Sheet1)の場合、大きい順に(Sheet2)のA列にB4.A3.D2…と書くことはできるのでしょうか??
>また、できるのならば、同得点の場合の処理もどうにかお願いします。
>
>
>(Sheet1)           (Sheet2)
>  A  B  C  D  E        A  B  C
>1 100 123 321 566 129     1   B4
>2 578 654 156 846 345  ⇒ 2   A3
>3 875 659 800 124 651     3   D2
>4 758 986 425 154 445     4   C3

標準モジュールに
'====================================================
Sub test()
  Dim ans As Variant
  Dim rng As Range
  Dim rr As Long
  Dim r As Long, c As Long
  Set rng = Worksheets("sheet1").Range("a1:e4")
  ans = Evaluate("if(" & rng.Address(, , , True) & "<>""""," & _
         "rank(" & rng.Address(, , , True) & "," & rng.Address(, , , True) & "))")
  With Worksheets("sheet2")
    .Range("a1:a" & rng.Count).Value = ""
    For r = LBound(ans, 1) To UBound(ans, 1)
     For c = LBound(ans, 2) To UBound(ans, 2)
       rr = ans(r, c)
       Do Until .Cells(rr, 1).Value = ""
        rr = rr + 1
        Loop
       .Cells(rr, 1).Value = .Cells(r, c).Address
       Next
     Next
    End With
End Sub

試してみて下さい

【45812】Re:どのようにやるのでしょうか?
回答  Kein  - 07/1/14(日) 23:42 -

引用なし
パスワード
   こんな感じでどうでしょーか ?
ちょっとややこしいコードになりますが、テストは成功しています。

Sub LGV_Address()
  Dim Cc As Long, i As Long, j As Long
  Dim ErW As Long, Cnt As Long
  Dim Ad As String
  Dim MyV As Variant
  Dim MyR As Range, C As Range, FR As Range
 
  Set MyR = Worksheets("Sheet1").Range("A1").CurrentRegion
  Cc = MyR.Columns.Count: Ad = MyR.Address
  For i = 1 To MyR.Rows.Count
   If i = 1 Then
     j = 1
   Else
     j = j + Cc
   End If
   MyV = WorksheetFunction.Transpose(MyR.Rows(i).Value)
   Sheets("Sheet2").Cells(j, 1).Resize(Cc).Value = MyV
  Next i
  With Sheets("Sheet2")
   ErW = .Range("A65536").End(xlUp).Row
   With .Range("A1:A" & ErW)
     .Sort Key1:=.Cells(1), Order1:=xlDescending, _
     Header:=xlNo, Orientation:=xlSortColumns
     .Offset(, 255).Formula = "=COUNTIF(Sheet1!" & Ad & ",$A1)"
   End With
   i = 1: j = 0
   Do
     Cnt = .Cells(i, 256).Value
     For j = 1 To Cnt
      If j = 1 Then
        Set FR = _
        MyR.Find(.Cells(i, 1).Value, , xlValues, xlWhole)
      Else
        Set FR = _
        MyR.Find(.Cells(i, 1).Value, FR, xlValues, xlWhole)
      End If
      .Cells(i, 1).Value = FR.Address(0, 0)
      i = i + 1
     Next j
     Set FR = Nothing
   Loop While i <= ErW
   .Range("IV:IV").ClearContents: .Activate
  End With
  Set MyR = Nothing
End Sub

【45874】Re:どのようにやるのでしょうか?
お礼  KAI  - 07/1/16(火) 20:51 -

引用なし
パスワード
   ありがとうございました!!!

6333 / 13646 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free