Excel2007でヘルプをお願いします

質問

Excel2007でヘルプをお願いします。
(1)、(U2:U11)に上から順にアイウエオカキクケコと入ってます。
(2)、(V2:V11)に、[(1)を参照記号してどこからかで集められた]個数データが入ってます

(3)、(W2:W11)にも(2)と同じような流れで入ってます。

図
| U | V | W |
| ア | 16| 24|
| イ | 23| 18|
| ウ | ・| ・|
| ・ | ・| ・|
…とこんな感じです。
このデータは今回とは関係のないマクロボタン(1)が押される度に変わります。
(4)、マクロボタン(1)が押されデータが変わる度に(V2:V11)の数字データを参照にしてU列(ア～コ)を数字データが多い順に並べ変えsheet3の(C6:L6)へ[左が一番多い数字データの記号となるように]横倒しにコピペし、

(W2:W11)の場合もsheet4に(C6:L6)に(4)と同じようにコピペしたいです。
マクロボタンを作り、それを押す度にsheet3とsheet4にある(C6:L6)の下に向かって次々と入れていきたいです。(C7:L7)→(C8:L8)と
格子も付けて文字もセンターに揃えたいです。
よろしくお願いいたします。

回答No.8

watabe007 · ベストアンサー

>黄色くなりますし×マークも出てません。
こちらのテストでは正常に行われていますよ
今回増やしたのはこの2行だけです
Cells(.Row, "N").Resize(, 6).Borders.LineStyle = xlContinuous
Cells(.Row, "N").Resize(, 6).HorizontalAlignment = xlCenter
この2行をコメントアウトして元通りにすれば×印は付くのですね

お礼

その二行をとると付きます。

不思議ですねぇ(。-`ω´-)ンー

補足

こんばんはーwatabe007さん！！！できました！！！！！
Cells(.Row, "N").Resize(, 6).HorizontalAlignment = xlCenter
の
HorizontalAlignmentがスペルも間違ってないのにenter押しても小文字だったのでただ記述通り直してみても、失敗しました。

そこで一度その部分をデリートしてみて再度書いてみたら上手くいきました。

どうしてなんですかね？そういうことってあるものなんですか？

このまま質問続けさせて下さい。よろしいでしょうか？

回答No.11

watabe007

アッ、書き忘れ
Sheet1のRange("X2:X11")を作業列と使用させていただいております。

お礼

しっかりと休んでください。おやすみなさい。

回答No.10

watabe007

そのまえに
Sub Test２()の代わりにSub Test3()を試して頂けませんか
関数を使ってコードを簡素化してみました。
最初のデータが有るシート名はSheet1としています。
(関数の中でSheet1としていますので違うとエラーが出ます。)
希望通りの動きでなかったり、エラーが出たのなら捨ててください。
Sub Test3()
Dim LR As Long
Range("X2:X11").Formula = "=V2-ROW()/10^2"
With Worksheets("Sheet3")
LR = .Cells(Rows.Count, "C").End(xlUp).Row + 1
If LR < 6 Then LR = 6
With .Cells(LR, "C").Resize(, 10)
.Formula = "=INDEX(Sheet1!$U2:$U11,MATCH(LARGE(Sheet1!$X2:$X11,COLUMN(A1)),Sheet1!$X2:$X11,0),1)"
.Value = .Value
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
End With
End With
Range("X2:X11").Formula = "=W2-ROW()/10^2"
With Worksheets("Sheet4")
LR = .Cells(Rows.Count, "C").End(xlUp).Row + 1
If LR < 6 Then LR = 6
With .Cells(LR, "C").Resize(, 10)
.Formula = "=INDEX(Sheet1!$U2:$U11,MATCH(LARGE(Sheet1!$X2:$X11,COLUMN(A1)),Sheet1!$X2:$X11,0),1)"
.Value = .Value
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
End With
End With
Range("X2:X11").ClearContents
End Sub

お礼

こんばんはwatabe007さん。
ありがとうございます。

回答No.9

watabe007

>こんばんはーwatabe007さん！！！できました！！！！！
>Cells(.Row, "N").Resize(, 6).HorizontalAlignment = xlCenter
良かったです。
私がコードをアップするのに見やすくする為に
　　Cells(.Row, "N").Resize(, 6).HorizontalAlignment = xlCenter
　↑全角のスペースを入れています。それが悪影響を及ぼしたのでしょうね
また、語尾にも全角スペースなどが有ると同じ事が起こるようですね
>このまま質問続けさせて下さい。よろしいでしょうか？
今回で、私なりに一区切りが付いたように思いますので
一旦、休ませていただきます。m(_ _)m

お礼

>　　Cells(.Row, "N").Resize(, 6).HorizontalAlignment = xlCenter
　↑全角のスペースを入れています。それが悪影響を及ぼしたのでしょうね
また、語尾にも全角スペースなどが有ると同じ事が起こるようですね
>

違うんです。watabe007さんが失敗とかじゃありません。私は、作って頂いたソースを手打ちで書いています。ネットもしてないパソコンビギナーが野望を持ち、油で汚れた黒い手をジフで洗って黒い泡が出来るので961awaawaなんですｗ

後少しなんですが質問にお気付き下さいましたら御協力よろしくお願いしますm(__)m

回答No.7

watabe007

>これに格子を入れてセンターに揃えたいです。
あれ？ 前回の質問で(投稿日時 - 2018-12-18 22:14:50)
>sheet3、4にセルC6～L6にア～コがバラバラにはいります。
>N6～S6に格子を入れました。
と、既に格子を入れているのでは？
取敢えず、格子とセンター処理を行いました。
Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim myC As Variant
　　With Target
　　　　If .Count > 1 Then Exit Sub
　　　　If .Value = "" Then Exit Sub
　　　　If .Row < 6 Or .Column <> 14 Then Exit Sub
　　　　myC = Application.Match(.Value, Cells(.Row, "C").Resize(, 10), 0)
　　　　If Not IsError(myC) Then
　　　　　　Cells(.Row, "B").Offset(, myC).Interior.Color = vbYellow
　　　　　　Cells(.Row, "N").Resize(, 6).Borders.LineStyle = xlContinuous
　　　　　　Cells(.Row, "N").Resize(, 6).HorizontalAlignment = xlCenter
　　　　　　Cells(.Row, "N").Offset(, (myC + 1) \ 2).Value = "×"
　　　　End If
　　End With
End Sub

お礼

こんにちはーwatabe007さん。ご解答ありがとうございます。ですが上手くいきません。
下から6、7行目の
実行時エラー438が出て
Cells(.Row, "N").Resize(, 6).HorizontalAlignment = xlCenter

黄色くなりますし×マークも出てません。

補足

こんばんはーwatabe007さん！！！できました！！！！！
Cells(.Row, "N").Resize(, 6).HorizontalAlignment = xlCenter
の
HorizontalAlignmentがスペルも間違ってないのにenter押しても小文字だったのでただ記述通り直してみても、失敗しました。

そこで一度その部分をデリートしてみて再度書いてみたら上手くいきました。

どうしてなんですかね？そういうことってあるものなんですか？

回答No.6

watabe007

>N6にアと入れるとC6～L6からアを探しだし[例えばE6にアが入るとして]
>セルに色付けしてセルP6に×マークをいれたいです。
Sheet3、Sheet4のシートモジュールに以下のコードを貼り付けてください。
Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim myC As Variant
　　With Target
　　　　If .Count > 1 Then Exit Sub
　　　　If .Value = "" Then Exit Sub
　　　　If .Row < 6 Or .Column <> 14 Then Exit Sub
　　　　myC = Application.Match(.Value, Cells(.Row, "C").Resize(, 10), 0)
　　　　If Not IsError(myC) Then
　　　　　　Cells(.Row, "B").Offset(, myC).Interior.Color = vbYellow
　　　　　　Cells(.Row, "N").Offset(, (myC + 1) \ 2).Value = "×"
　　　　End If
　　End With
End Sub

お礼

できましたwatabe007さん。これに格子を入れてセンターに揃えたいです。付け加えは何が必要ですか？

回答No.5

watabe007

>N6にアと入れるとC6～L6からアを探しだし[例えばE6にアが入るとして]
>セルに色付けしてセルP6に×マークをいれたいです。
ならC6にアが有った場合は、N6に×マーク ？

お礼

こんばんはーwatabe007さん。

O列はCDの２列に対応する形にして欲しいです。

OはCとD、PはEとF、QはGとH、RはIとJ、SはKとLに対応する形が希望です。
sheet3、4のN列には、sheet1のC列(マクロボタンを押す度に下に向かってセル番号がふえる)からもってきたア～コのいずれかが入る形になります。

一番新しいデータではN列の最後尾は入りません(結果が出てから入ります)。なので始まりのN6にもやり始めなので入ってないことになります。

ということから重要な説明があることに気付かずに例えで適当にアと言っちゃいました。

説明や質問って難しい(;゜∀゜;) 改めてそうおもいました。

一度にマクロって感じじゃなくてもいいんです。小分けにしてから連結って形でも有り難く思います。

いつも頭が下がりっぱなしです。m(__)m

回答No.4

watabe007

>N6にアと入れるとC6～L6からアを探しだし
N6に、どの段階で「ア」を入れるのですか
入れるのはVBA、手入力？ 入るのは「ア」だけですか？

お礼

watabe007さん！！！あなた様の突っ込みが凄すぎてびっくりしました！！
すみませんが今日はもうゆっくりとして頂くのが私にとって望ましいですm(__)m
質問するのがむずかしくて結構時間が要ります。

明日までには解決してお礼にて質問致します。また御協力下さい。おやすみなさい。

補足

凄い突っ込みにびっくりしました。!!本当に助けられます。

最初の一発目は例としてアとしましたがこれでは説明不足で良くなかったですし質問を改良してまた似たような質問という形になってしまいます。
失礼しました。

sheet1のA1に今のところ1000と入ってます。C列にはすでに何千行ともなるセルにア～コのいずれかが入ってます。
A1の数字を利用してC999の記号をコピーしてsheet3、4のN列にペイストする形なんです。

ちなみにA1の1000はC999を処理したんで999+1がなされた後の形で1000なんです。

回答No.3

watabe007

>このまま質問してもよろしいでしょうか？
どうぞ~

お礼

ではこのままお世話になります。先程の続きでお分かり頂けることから、sheet3、4にセルC6～L6にア～コがバラバラにはいります。ここから質問になります。
N6～S6に格子を入れました。
OはCD列、PはEF列、QはGH列、RはIJ列、SはKL列に対応してます。
N6にアと入れるとC6～L6からアを探しだし[例えばE6にアが入るとして]セルに色付けしてセルP6に×マークをいれたいです。
セルC6～L6が下に向かってC7～L7…といくように、N6～S6もそれにあわせて対応したいです。

よろしくお願いいたします。

回答No.2

watabe007

Sub Test2()
　　Dim v As Variant, tmp(1) As Variant
　　Dim i As Long, j As Long, LR As Long
　　With Range("U2:W11")
　　　　v = .Value
　　　　For i = 1 To 10
　　　　　　For j = 10 To i Step -1
　　　　　　　　If v(i, 2) < v(j, 2) Then
　　　　　　　　　　tmp(0) = v(i, 1)
　　　　　　　　　　tmp(1) = v(i, 2)
　　　　　　　　　　v(i, 1) = v(j, 1)
　　　　　　　　　　v(i, 2) = v(j, 2)
　　　　　　　　　　v(j, 1) = tmp(0)
　　　　　　　　　　v(j, 2) = tmp(1)
　　　　　　　　End If
　　　　　　Next j
　　　　Next i
　　　　v = Application.Index(v, 0, 1)
　　　　With Worksheets("Sheet3")
　　　　　　LR = .Cells(Rows.Count, "C").End(xlUp).Row + 1
　　　　　　If LR < 6 Then LR = 6
　　　　　　With .Cells(LR, "C").Resize(, 10)
　　　　　　　　.Value = Application.Transpose(v)
　　　　　　　　.Borders.LineStyle = xlContinuous
　　　　　　　　.HorizontalAlignment = xlCenter
　　　　　　End With
　　　　End With
　　　　v = .Value
　　　　For i = 1 To 10
　　　　　　For j = 10 To i Step -1 '⇒
　　　　　　　　If v(i, 3) < v(j, 3) Then
　　　　　　　　　　tmp(0) = v(i, 1)
　　　　　　　　　　tmp(1) = v(i, 3)
　　　　　　　　　　v(i, 1) = v(j, 1)
　　　　　　　　　　v(i, 3) = v(j, 3)
　　　　　　　　　　v(j, 1) = tmp(0)
　　　　　　　　　　v(j, 3) = tmp(1)
　　　　　　　　End If
　　　　　　Next j
　　　　Next i
　　　　v = Application.Index(v, 0, 1)
　　　　With Worksheets("Sheet4")
　　　　　　LR = .Cells(Rows.Count, "C").End(xlUp).Row + 1
　　　　　　If LR < 6 Then LR = 6
　　　　　　With .Cells(LR, "C").Resize(, 10)
　　　　　　　　.Value = Application.Transpose(v)
　　　　　　　　.Borders.LineStyle = xlContinuous
　　　　　　　　.HorizontalAlignment = xlCenter
　　　　　　End With
　　　　End With
　　End With
End Sub

お礼

watabe007さん！！！ピタッときました。ありがとうございます。この続きなんですがこのまま質問してもよろしいでしょうか？

そうすると長い質問が省かれてたすかります。

回答No.1

watabe007

Sub Test()
　　Dim v As Variant, LR As Long
　　With Range("U2:W11")
　　　　'並べ替え前の状態を記録
　　　　v = .Value
　　　　.Sort Key1:=Range("V2"), Order1:=xlDescending, Header:=xlNo
　　　　With Worksheets("Sheet3")
　　　　　　LR = .Cells(Rows.Count, "C").End(xlUp).Row + 1
　　　　　　If LR < 6 Then LR = 6
　　　　　　Range("U2:U11").Copy
　　　　　　With .Cells(LR, "C")
　　　　　　　　.PasteSpecial Paste:=xlPasteValues, Transpose:=True
　　　　　　　　.Resize(, 10).Borders.LineStyle = xlContinuous
　　　　　　　　.Resize(, 10).HorizontalAlignment = xlCenter
　　　　　　End With
　　　　End With
　　　　.Sort Key1:=Range("W2"), Order1:=xlDescending, Header:=xlNo
　　　　With Worksheets("Sheet4")
　　　　　　LR = .Cells(Rows.Count, "C").End(xlUp).Row + 1
　　　　　　If LR < 6 Then LR = 6
　　　　　　Range("U2:U11").Copy
　　　　　　With .Cells(LR, "C")
　　　　　　　　.PasteSpecial Paste:=xlPasteValues, Transpose:=True
　　　　　　　　.Resize(, 10).Borders.LineStyle = xlContinuous
　　　　　　　　.Resize(, 10).HorizontalAlignment = xlCenter
　　　　　　End With
　　　　End With
　　　　'並べ替え前の状態に戻す
　　　　.Value = v
　　End With
End Sub

お礼

いつも御協力ありがとうございます。捕捉を見てください。

補足

こんばんはーwatabe007さん。早速の解答ありがとうございます。今、やってみたのですが形はバッチしで意志疎通が出来てて完璧だと思ったんですが……問題がありました(;゜∀゜;)

それはV列W列の値が更新されずsheet3、4に同じ値が出てきます。
V列W列には=COUNTIFS…から始まる関数が入ってまして、作って頂いたソースで実行すると関数が消えて値の更新がなされてませんでした。

私の質問不足でした。再度、補助お願いいたします。