[[20190113075758]]　『Rankで文字詰』（819）　ページの最後に飛ぶ

『Rankで文字詰』（819）

お世話になります。

A列に順位、B列に数値が入っていて19行間隔で100万行位有ります。。

順位に対してB列の数値が左右どちらかに動くものを作りたいと思っています。

そこで
Sub ランク()

    Dim c As Range
    Range("B1:B18").HorizontalAlignment = xlcenter
    For Each c In Range("B1:B18").SpecialCells(2)
        If WorksheetFunction.Rank(c.Value, Range("B1:B18")) > c.Offset(, -1).Value Then
            c.Value.HorizontalAlignment = xlRight
        ElseIf WorksheetFunction.Rank(c.Value, Range("B1:B18")) < c.Offset(, -1).Value Then
            c.Value.HorizontalAlignment = xlLeft
        End If
    Next c
End Sub

を作ってみましたが、データを最後まで回せません。
フォントサイズを１５に設定してデータを最後まで回す方法を教えてください。

それと、行列変換をしてSheet2に転記したいのですが
Sub Test2() '横に並べる

    Dim i As Long
    Dim pos As Range

    Dim shF As Worksheet
    Dim shT As Worksheet

    Set shF = Sheets("Sheet1")  '★元シート
    Set shT = Sheets("Sheet2")  '★転記シート

    Set pos = shT.Range("A1")   '転記開始位置

    For i = 1 To shF.Range("B" & Rows.Count).End(xlUp).Row Step 19
        pos.Resize(, 18).Value = WorksheetFunction.Transpose(shF.Cells(i, "B").Resize(18))
        Set pos = pos.Offset(1)   '次の貼り付け位置
    Next

 End Sub
上記のコードでは書式設定を保持したまま転記できないので
書式設定を保持したままSheet2に転記する方法を教えてください。

みなさまに知恵をお貸しください。
よろしくお願い致します。

＜使用 Excel：Excel2007、使用 OS：Windows7 ＞

＞データを最後まで回せません。
最終行まで繰り返す方法を教えろということですかね。
後半部分で
For i = 1 To shF.Range("B" & Rows.Count).End(xlUp).Row Step 19
と言う書き方を使ってますよね。
同じようにすればよいのでは？
　
単にRange("B1:B18")としている箇所を
19行ごとのセルを基準にして、
Cells(i,"A").Range("B1:B18")のように変更すればよいと思います。
　
後半の質問に関しては、行列を反転したCopyメソッドを使えばよいと思いますが。
トライしてみてください。
（γ） 2019/01/13(日) 08:45

γ様
コメントありがとうございます。

過去ログから検討を付けて作ったものなので正直分かっていません。
具体的に教えて頂けませんか？

上記の質問の中にフォントサイズの変更もあるのですがそれも一緒にお教えください。

よろしくお願いいたします。
（819） 2019/01/13(日) 10:33

 訂正します｡
 Copyメソッドだけじゃない､肝心なのは PasteSpecialメソッドです｡
 マクロ記録した例は次のようなものです。
 Sub Macro1()
     Selection.Copy
     Range("A7").PasteSpecial Paste:=xlPasteAll, _
         Operation:=xlNone, SkipBlanks:=False, Transpose:=True
 End Sub

 フォントの変更も簡単にマクロ記録できますよ。
 Selection.Font.Size = 15 
 ですね。
（γ） 2019/01/13(日) 11:56

γ様

私にはハードルが高いようです。
致命的な欠点があってコードを書く際のイメージが出来ない。
見よう見まねでは何となく分かるのですが、完全に分かる気がしないです。
又、周りにアドバイスを貰える様な仲間もいないのでどうしても分からないままです。

自分なりにコード書いてみましたが、やはり動きません。

手直しお願いできないでしょうか？

Sub ランク()

    Dim c As Range
    Dim i As Range
    Range("B:B").HorizontalAlignment = xlCenter

    For i = 1 To .Range("B" & Rows.Count).End(xlUp).Row Step 19

    For Each c In Range("B1:B18").SpecialCells(2)
        If WorksheetFunction.Rank(c.Value, Range("B1:B18")) > c.Offset(, -1).Value Then
            c.Value.HorizontalAlignment = xlRight
            .Font.Size = 15
        ElseIf WorksheetFunction.Rank(c.Value, Range("B1:B18")) < c.Offset(, -1).Value Then
            c.Value.HorizontalAlignment = xlLeft
            .Font.Size = 15
        End If
    Next c
    Next i
End Sub

Sub Test2() '横に並べる

    Dim i As Long
    Dim pos As Range

    Dim shF As Worksheet
    Dim shT As Worksheet

    Set shF = Sheets("Sheet1")  '★元シート
    Set shT = Sheets("Sheet2")  '★転記シート

    Set pos = shT.Range("A1")   '転記開始位置

    For i = 1 To shF.Range("B" & Rows.Count).End(xlUp).Row Step 19
        pos.Resize(, 18).Value = .Copy (shF.Cells(i, "B").Resize(18)).PasteSpecial Paste Transpose:=True
        Set pos = pos.Offset(1)   '次の貼り付け位置
    Next

 End Sub

宜しくお願い致します。

（819） 2019/01/13(日) 15:58

確認していませんでしたが、
そのコードは誰が書いたものですか？
というのは、ランクは最大18人のなかのランク
なんですか？それとも全体？
以前あった質問は全体だった気がしますけど。

（γ） 2019/01/13(日) 18:10

γ様

お人が悪いです
色々ヒントは頂いていますがγ様が思う程分かってはいません。
正直私はギブアップします。
私は解を求めているのであって問答をしているのでは有りません。
この様な事をしていたら終わらないと思います。
（819） 2019/01/13(日) 18:55

[[20190104120614]]
によく似た話があって、
そのときは全員の中での順位を決めていた記憶があったので、
別HNの同一人物かと思って確認したまでです。
　
最大18人ごとのランクを求めているのか、
全員のなかのランクを求めているのか、
改めて確認した訳です。
後者なら
手戻りになって無駄骨は折りたくないですからね。
　
それを、「これじゃいつまで経っても終わらない」
と打ち切るなら、それも結構でしょう。
　
内容を確認する問答は不要で、
何度でもコードを出せ、
こっちが Yes Noを判定するから、
という方針なら、こちらこそお断りします。
　
[[20190110081905]]
も随分な終わり方ですね。
　
それと、質問するときに、
上司がどうこうということは質問と一切関係ないです。
そういう雑音は入れないほうがよいと思いました。

（γ） 2019/01/13(日) 19:52

 こんばんは！

 ちょっと書いてみたけど、、いりますぅ？？？？

 >A列に順位、B列に数値が入っていて19行間隔で100万行位有ります。。

 100万行かぁ、、、520行ほどでしか試してないけどね(￣▽￣;)

 動かなかったら、、、、ごめんちゃいm(__)m

 私の今の職場のデータは多くて270行ぐらいなんです。でも、結構、満足しています。(なんのこっちゃ？？？）(^^;

 あっ、後、なるべく原案を残そうと思ったけど、、、残ってないか(笑)

 まぁ、後はご自身でアレンジしてみて下さい。

 では、では、
Sub てすと()
Dim MyA As Variant
Dim MyB() As Variant
Dim i As Long
Dim n As Long
Dim k As Long
Dim r As Long
Dim MyTimer As Single
MyTimer = Timer
Application.ScreenUpdating = False
    With Sheets("Sheet1")
        .Range("C:D").Clear
        .Range("B:B").Font.Size = 11
        MyA = .Range("B1", .Range("B" & .Rows.Count).End(xlUp)).Offset(, -1).Resize(, 2).Value
        .Range("B1").Resize(UBound(MyA, 1)).HorizontalAlignment = xlCenter
        ReDim MyB(LBound(MyA, 1) To UBound(MyA, 1), LBound(MyA, 2) To UBound(MyA, 2))
        For n = LBound(MyA, 1) To UBound(MyA, 1) Step 19
            k = IIf(n + 17 > UBound(MyA, 1), UBound(MyA, 1), n + 17)
            For i = n To k
                If Application.Rank(.Range("B" & i), .Range("B" & n).Resize(18)) > Val(MyA(i, 1)) Then
                    MyB(i, 1) = 1
                ElseIf Application.Rank(.Range("B" & i), .Range("B" & n).Resize(18)) < Val(MyA(i, 1)) Then
                    MyB(i, 2) = 1
                End If
            Next
        Next
        .Range("C1").Resize(UBound(MyB, 1), UBound(MyB, 2)).Value = MyB
        On Error Resume Next
            For n = LBound(MyA, 1) To UBound(MyA, 1) Step 10000
                k = IIf(n + 9999 > UBound(MyA, 1), UBound(MyA, 1) - n, 10000)
                With .Range("C1").Offset(n - 1).Resize(k + 1).SpecialCells(xlCellTypeConstants, 23).Offset(, -1)
                    .HorizontalAlignment = xlRight
                    .Font.Size = 15
                End With
                With .Range("D1").Offset(n - 1).Resize(k + 1).SpecialCells(xlCellTypeConstants, 23).Offset(, -2)
                    .HorizontalAlignment = xlLeft
                    .Font.Size = 15
                End With
            Next
        On Error GoTo 0
        .Range("C:D").Clear
    End With
Application.ScreenUpdating = True
Erase MyA, MyB
MyTimer = Timer - MyTimer
MsgBox "処理が完了しました。" & vbCrLf & Format(MyTimer, "###0.000" & "秒")
End Sub

 Sub てすと2() '横に並べる
Dim i As Long
Dim j As Long
Dim r As Long
Dim n As Long
Dim pos As Range
Dim shF As Worksheet
Dim shT As Worksheet
Dim MyA As Variant
Dim MyTimer As Single
    MyTimer = Timer
    Set shF = Sheets("Sheet1")  '★元シート
    Set shT = Sheets("Sheet2")  '★転記シート
    Set pos = shT.Range("A1")   '転記開始位置
        Application.ScreenUpdating = False
            With shF
                MyA = shF.Range("B1", .Range("B" & .Rows.Count).End(xlUp)).Value
            End With
            shT.Cells.Clear
            For n = LBound(MyA, 1) To UBound(MyA, 1) Step 19
                shF.Range("B" & n).Resize(18).Copy
                pos.Offset(r).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=True
                r = r + 1
            Next
        Application.ScreenUpdating = True
    Application.CutCopyMode = False
    Set shF = Nothing
    Set shT = Nothing
    Set pos = Nothing
Erase MyA
MyTimer = Timer - MyTimer
MsgBox "処理が完了しました。" & vbCrLf & Format(MyTimer, "###0.000" & "秒")
End Sub
（SoulMan） 2019/01/13(日) 20:45

Sub ランク2()

    Dim c As Range, LastRow As Long, i As Long

    LastRow = Cells(Rows.Count, "B").End(xlUp).Row
    Range("B1:B" & LastRow).HorizontalAlignment = xlCenter
    For i = 1 To LastRow Step 19
        For Each c In Cells(i, "B").Resize(18).SpecialCells(2)
            If WorksheetFunction.Rank(c.Value, Cells(i, "B").Resize(18)) > c.Offset(, -1).Value Then
                c.HorizontalAlignment = xlRight
                c.Font.Size = 15
            ElseIf WorksheetFunction.Rank(c.Value, Cells(i, "B").Resize(18)) < c.Offset(, -1).Value Then
                c.HorizontalAlignment = xlLeft
                c.Font.Size = 15
            End If
        Next c
    Next i
End Sub

（ピンク） 2019/01/13(日) 20:53

＞残念ながら結果が違いました。
とならないことを祈る
（） 2019/01/13(日) 20:58

Sub 横に並べる2()

    Dim LastRow As Long, i As Long, j As Long
    Dim shF As Worksheet, shT As Worksheet

    Application.ScreenUpdating = False
    Set shF = Sheets("Sheet1")  '★元シート
    Set shT = Sheets("Sheet2")  '★転記シート
    LastRow = shF.Cells(Rows.Count, "B").End(xlUp).Row
    For i = 1 To LastRow Step 19
        j = j + 1
        shF.Cells(i, "B").Resize(18).Copy
        shT.Cells(j, "A").PasteSpecial Paste:=xlPasteAll, _
            Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    Next
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "完了!!", 64
End Sub

（ピンク） 2019/01/13(日) 21:13

 不適切な発言につき自己削除
（SoulMan） 2019/01/13(日) 22:08

説教じみた発言は控えていただきたいですね。
ひとそれぞれに発言のスタンスはありますから。
（γ） 2019/01/13(日) 23:37

SouiMan様、ピンク様、（）は稲葉様？
コードの提供とコメントありがとうございます。
物理的に移動しなければいけなくなってコメントを出せませんでした。

一番疲れているのはγ様だと思うので何も書き込みません。

SouiMan様のギターの話面白かったです。
また分からないことが出来たら質問させて頂きます。

ありがとうございました。

（819） 2019/01/14(月) 06:35

 あのさ、勝手に推測で人の名前出さないでくれます？

 力になれなくてすみません、で終わらせた私が今さらそのような書き込みのために
 労力割くと思いますか？
 いや、結果からみたらそう思われていたのでしょうね

 最後にどんな解決されるのか楽しみにしていたのにあんまりだ。
（稲葉） 2019/01/14(月) 07:41

 おはようございます。
朝起きてよくよく考えたらお題を完全に読み違えてますね？特に　てすと２　の方、、、すみません。

 上のコードを張り替えておきましたので差し替えて下さい。

 >SouiMan様のギターの話面白かったです。

 そういってもらえるといいんだけど、実は、あの話には続きがあってね

 中学のギターって年齢も年齢だからそんなに技術的には差がないのよ

 で、それ以来私は、教え習う時はこのFeelingをすごく大切にする様になったって話なんだけど、、、

 例えば、ゴルフ、、デービス・ラブ三世が言った、、

 Topからグリップエンドがボールを指す様に、、、振り下ろす感じが凄く大事なんだよ、、投げるんじゃなくてね　とか

 このExcelのVbaもトピ主さんと私とではそんなに差があるわけじゃなくて、私なんかは、会社でいつも

 無理難題を押し付けられているわけで、、(会社の人がみているとまずいから、、やります、します、やらせていただきます、の精神です。とよいしょしといて(笑)）

 で、何が言いたいかというと、わからいことがあればぐぐる、、で、そのものずばりはないけど、、ヒントはある。

 後は、それを応用するだけで、私なんかはぐぐるぐぐる(笑)

 ちなみに、てすと　の方は、1035965行　のサンプルで、、

 186.766
 257.445
 259.895

 てすと2　の方は、
 553.625
 548.441
 547.637

 でした。　もう、返ってこないのかと不安だったけど、、なんとか、、、

 で、最後におちなんですけど、、、唯一、Feeling　でやっちゃいけないのが　お馬ちゃん、、、

 お馬ちゃんだけはちゃんと考えて買わないとだめです。

 だれか、お馬ちゃんの買い方、、おせぇ～～て！！！　って言う　お話でした。(^^;

 では、では、
（SoulMan） 2019/01/14(月) 11:58

 すみません。お騒がせしてます。
 どうも100万行くらいになると、
 >.SpecialCells(xlCellTypeConstants, 23).Offset(, -1)　が機能していないみたいです(^^;

 限界があるんでしょうね？？？

 仕方ないので　10000　Stepにしてみました。

 でも、その方が
 225.836
 224.203
 と少し早いんですよね？？？

 てすと　の方を差し替えておきました。すみません。。

 なんかボロボロになってきましたね(笑)
（SoulMan） 2019/01/14(月) 15:51

SoulMan様
そんなに気を使わなくても大丈夫です。
色々ありがとうございます。

稲葉様
推測でものを言いご迷惑おかけしました。

データの方に不備が有りちょっと時間がかかりましたが希望の物が出来ました。
皆様のご協力で明日のプレゼンには間に合いそうです。

＞だれか、お馬ちゃんの買い方、、おせぇ～～て！！！　って言う　お話でした。
SoulMan様はお馬さんするのですか？
是非お仲間に入れて頂きたく・・・連絡先を教えてください。
（819） 2019/01/14(月) 16:29

コメント返信：

[ 一覧(最新更新順) ]

[[20190113075758]] 『Rankで文字詰』（819） ページの最後に飛ぶ

[[20190113075758]]　『Rankで文字詰』（819）　ページの最後に飛ぶ