Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
2051 / 13665 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【70370】特殊な行列の入れ替え y.y 11/11/7(月) 0:00 質問[未読]
【70371】Re:特殊な行列の入れ替え かみちゃん 11/11/7(月) 5:37 発言[未読]
【70374】Re:特殊な行列の入れ替え UO3 11/11/7(月) 13:15 発言[未読]
【70375】Re:特殊な行列の入れ替え UO3 11/11/7(月) 13:32 発言[未読]
【70379】Re:特殊な行列の入れ替え ichinose 11/11/8(火) 7:04 発言[未読]
【70381】Re:特殊な行列の入れ替え UO3 11/11/8(火) 9:31 発言[未読]
【70382】Re:特殊な行列の入れ替え UO3 11/11/8(火) 9:38 発言[未読]
【70378】Re:特殊な行列の入れ替え y.y 11/11/7(月) 22:03 お礼[未読]
【70387】Re:特殊な行列の入れ替え panpan 11/11/11(金) 13:22 回答[未読]
【70380】Re:特殊な行列の入れ替え Yuki 11/11/8(火) 9:16 発言[未読]
【70370】特殊な行列の入れ替え
質問  y.y  - 11/11/7(月) 0:00 -
引用なし
パスワード
   ちょっと特殊な行列の入れ替えをしたいと思っています．

（以下，1234は行をABCDは列を表します．）

普通の行列入れ替えであれば，

　 A 　　　　　A B C D
1　a　　　　1　a b c d
2　b　　→
3　c
4　d

となると思うのですが，

　 A 　　　　　A B C D
1　a　　　　1　d c b a
2　b　　→
3　c
4　d

としたいのです．
セルのコピペプログラム「Worksheets(1).cells(1,1).copy Destination:=Worksheets(1).cells(1,4)」などを繰り返せばできるのですが，
データ数が多くなると時間がかかってしまうのです．
もちろんFor=1 to 100とかでやっているのですが，どうも時間がかかってしまいます．（officeを2003→2010に変えたら遅くなった気が…）

何か一発で入れ替えを行なう方法はありませんでしょうか？
よろしくお願いします．
【70371】Re:特殊な行列の入れ替え
発言  かみちゃん  - 11/11/7(月) 5:37 -
引用なし
パスワード
   こんにちは。かみちゃん　です。

> 特殊な行列の入れ替えをしたい

私は、以下のような感じでしています。

Sub Sample()
　SpecialTranspose Range("A1:A4"), Range("C1")
End Sub

Function SpecialTranspose(rng1 As Range, rng2 As Range, Optional bln As Boolean = False)
　Dim v As Variant
　Dim vv As Variant
　Dim x As Long, y As Long, xx As Long, yy As Long, yyy As Long
　
　v = rng1.Value
　xx = UBound(v, 2)
　yy = UBound(v, 1)
　ReDim vv(1 To xx, 1 To yy)
　For x = 1 To xx
　　yyy = 0
　　For y = yy To 1 Step -1
　　　yyy = yyy + 1
　　　vv(x, yyy) = v(y, x)
　　Next
　Next

　If bln Then
　　rng1.ClearContents
　End If
　rng2.Cells(1, 1).Resize(xx, yy).Value = vv
End Function

上記のうち、

SpecialTranspose Range("A1:A4"), Range("C1")

は、

Range("A1:A4") は、入れ替え元セル範囲
Range("C1") は、入れ替え先の左上のセル
※Range("A1"), True とすると、入れ替え元を消去して、同じ位置に入れ替えます。

いろいろ試してみてください。
【70374】Re:特殊な行列の入れ替え
発言  UO3  - 11/11/7(月) 13:15 -
引用なし
パスワード
   ▼かみちゃん さん：

こんにちは

かみちゃん　のコードの「パクリ」です。

Sub Test()
　　Call TransposeRev([A1:B10], [C1])
End Sub

Private Sub TransposeRev(fromR As Range, toCell As Range)
　　Dim v As Variant
　　Dim w As Variant

　　Dim i As Long, j As Long

　　v = WorksheetFunction.Transpose(fromR)
　　w = v
　　For j = UBound(v, 2) To LBound(v, 2) Step -1
　　　　For i = LBound(v, 1) To UBound(v, 1)
　　　　　　w(i, UBound(v, 2) + LBound(v, 2) - j) = v(i, j)
　　　　Next
　　Next

　　toCell.Resize(UBound(w, 1), UBound(w, 2)).Value = w

End Sub
【70375】Re:特殊な行列の入れ替え
発言  UO3  - 11/11/7(月) 13:32 -
引用なし
パスワード
   こんにちは

作業配列を１つだけ、ループ回数も半分に減らしてみました。

Sub test()
　　Call TransposeRev([A1:B11], [C1])
End Sub

Private Sub TransposeRev(fromR As Range, toCell As Range)
　　Dim v As Variant
　　Dim w As Variant
　　
　　Dim i As Long, j As Long
　　
　　v = WorksheetFunction.Transpose(fromR)
　　
　　For j = LBound(v, 2) To UBound(v, 2) \ 2
　　　　For i = LBound(v, 1) To UBound(v, 1)
　　　　　　w = v(i, UBound(v, 2) + LBound(v, 2) - j)
　　　　　　v(i, UBound(v, 2) + LBound(v, 2) - j) = v(i, j)
　　　　　　v(i, j) = w
　　　　Next
　　Next

　　toCell.Resize(UBound(v, 1), UBound(v, 2)).Value = v

End Sub
【70378】Re:特殊な行列の入れ替え
お礼  y.y  - 11/11/7(月) 22:03 -
引用なし
パスワード
   ＞かみちゃんさん，UO3さん

ありがとうございます．
簡単にできると思ったら，なかなか複雑ですね…
まだまだ勉強が必要そうです…．
コードの方活用させていただきます．

ありがとうございました！
【70379】Re:特殊な行列の入れ替え
発言  ichinose  - 11/11/8(火) 7:04 -
引用なし
パスワード
   UO3 さん、おはようございます。


>
>作業配列を１つだけ、ループ回数も半分に減らしてみました。
>
>Sub test()
　　　Call TransposeRev([A1:A11], [C1])
>End Sub

揚げ足取る様なんですが、
上記の例でエラーになりませんか？

Transpose関数を使う位置を変えれば良さそうですが・・・。

>
>Private Sub TransposeRev(fromR As Range, toCell As Range)
>　　Dim v As Variant
>　　Dim w As Variant
>　　
>　　Dim i As Long, j As Long
>　　
>　　v = WorksheetFunction.Transpose(fromR)
>　　
>　　For j = LBound(v, 2) To UBound(v, 2) \ 2
>　　　　For i = LBound(v, 1) To UBound(v, 1)
>　　　　　　w = v(i, UBound(v, 2) + LBound(v, 2) - j)
>　　　　　　v(i, UBound(v, 2) + LBound(v, 2) - j) = v(i, j)
>　　　　　　v(i, j) = w
>　　　　Next
>　　Next
>
>　　toCell.Resize(UBound(v, 1), UBound(v, 2)).Value = v
>
>End Sub

StrReverseという関数がありましたよね？
↑これ使っても出来そうなんですけどねえ
他にもワークシート関数を使うとか・・・。
【70380】Re:特殊な行列の入れ替え
発言  Yuki  - 11/11/8(火) 9:16 -
引用なし
パスワード
   ▼y.y さん：
>ちょっと特殊な行列の入れ替えをしたいと思っています．
>何か一発で入れ替えを行なう方法はありませんでしょうか？
一発ではないと思いますよ。
単に入れ替えすればいいと思いますが。
Sub TEESTa()
　　Dim v1　As Variant
　　Dim v2　As Variant
　　Dim i　 As Long
　　
　　With Worksheets("Sheet1")
　　　　v1 = .Range("A1").CurrentRegion.Columns(1).Value
　　　　ReDim v2(1 To 1, 1 To UBound(v1))
　　　　For i = 1 To UBound(v1)
　　　　　　v2(1, (UBound(v1) + 1) - i) = v1(i, 1)
　　　　Next
　　　　' 以下張付ける場所
　　　　.Rows(1).ClearContents
　　　　.Columns(1).ClearContents
　　　　.Range("A1").Resize(1, UBound(v2, 2)).Value = v2
　　End With
End Sub
【70381】Re:特殊な行列の入れ替え
発言  UO3  - 11/11/8(火) 9:31 -
引用なし
パスワード
   ▼ichinose さん：

おはようございます

>揚げ足取る様なんですが、
>上記の例でエラーになりませんか？

えっえっ（汗）
こちらで、簡単なテストを何種類かやった限りでは
正常に処理されているんですが・・・

と、思いながらもichinoseさんのご指摘だから間違いはないだろうということで
ふと、１列の場合、やってなかったなぁ・・と。
エラーになりますね。ちょっとチューニングしてみます。

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

>StrReverseという関数がありましたよね？
>↑これ使っても出来そうなんですけどねえ
>他にもワークシート関数を使うとか・・・。

今は、ちょっと、このテーマに対してどう使うか、思い浮かびませんが
↑のチューニングのあと、今日の「頭の体操」の材料として、やってみます。
【70382】Re:特殊な行列の入れ替え
発言  UO3  - 11/11/8(火) 9:38 -
引用なし
パスワード
   チューニング結果です。
別方式のほうは、おきぬけであたまがぼぉ〜っとしていて
まだひらめきません。（永久にひらめかないかも）

Private Sub TransposeRev(fromR As Range, toCell As Range)
　　Dim v As Variant
　　Dim w As Variant
　
　　Dim i As Long, j As Long
　
　　v = fromR.Value
　
　　For i = LBound(v, 1) To UBound(v, 1) \ 2
　　　　For j = LBound(v, 2) To UBound(v, 2)
　　　　　　w = v(UBound(v, 1) + LBound(v, 1) - i, j)
　　　　　　v(UBound(v, 1) + LBound(v, 1) - i, j) = v(i, j)
　　　　　　v(i, j) = w
　　　　Next
　　Next

　　toCell.Resize(UBound(v, 2), UBound(v, 1)).Value = _
　　　　WorksheetFunction.Transpose(v)

End Sub
【70387】Re:特殊な行列の入れ替え
回答  panpan  - 11/11/11(金) 13:22 -
引用なし
パスワード
   列ソートを利用しては？


Sub 列ソート使用()
　　Dim r As Range
　　Dim r1 As Range
　　
　　Set r = Range("A1:A4")
　　Set r1 = Range("B1")
　　r.Copy
　　r1.PasteSpecial Transpose:=True
　　r1.EntireRow.Insert
　　With r1.Resize(2, r.Rows.Count).Offset(-1)
　　　　.Item(1).Value = 1
　　　　.Rows(1).DataSeries
　　　　.Sort Key1:=.Rows(1), Order1:=xlDescending, _
　　　　　　　Header:=xlNo, Orientation:=xlLeftToRight
　　　　.Item(1).EntireRow.Delete
　　End With
　　'r.EntireColumn.Delete
End Sub
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
2051 / 13665 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free