Excel VBA質問箱 IV

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

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


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

【20123】並べ替え やっしー 04/11/29(月) 1:12 質問[未読]
【20132】Re:並べ替え kazu 04/11/29(月) 14:19 発言[未読]
【20159】Re:並べ替え やっしー 04/11/30(火) 3:27 お礼[未読]
【20160】Re:並べ替え やっしー 04/11/30(火) 3:32 質問[未読]
【20161】Re:並べ替え ichinose 04/11/30(火) 8:20 回答[未読]
【20165】Re:並べ替え kazu 04/11/30(火) 10:19 発言[未読]
【20189】Re:並べ替え やっしー 04/12/1(水) 2:11 お礼[未読]
【20190】Re:並べ替え やっしー 04/12/1(水) 3:14 質問[未読]
【20192】Re:並べ替え ichinose 04/12/1(水) 7:43 発言[未読]
【20203】Re:並べ替え やっしー 04/12/1(水) 13:08 お礼[未読]

【20123】並べ替え
質問  やっしー  - 04/11/29(月) 1:12 -

引用なし
パスワード
   A列 B C  D  E
★ Q1 Q2 Q3 Q4 Q5

● Q1 Q2 Q3 Q5 Q5
  Q1 Q2 Q4 Q5 Q6
  Q1 Q2 Q4 Q6 Q7
  Q1 Q2 Q4 Q4 Q5
  :  Q2 Q3 Q6 Q5
  :  :  Q4 :  Q7
  :  :  :  :  Q6

またまたお尋ねします。

上の図のように●行目から同じQ数字に整列されていないQ数字がある場合、

★行の同じQ数字に合わせて整列させることはできますか?

【20132】Re:並べ替え
発言  kazu  - 04/11/29(月) 14:19 -

引用なし
パスワード
   ▼やっしー さん:
> A列 B C  D  E
>★ Q1 Q2 Q3 Q4 Q5
>
>● Q1 Q2 Q3 Q5 Q5
>  Q1 Q2 Q4 Q5 Q6
>  Q1 Q2 Q4 Q6 Q7
>  Q1 Q2 Q4 Q4 Q5
>  :  Q2 Q3 Q6 Q5
>  :  :  Q4 :  Q7
>  :  :  :  :  Q6
>
>またまたお尋ねします。
>
>上の図のように●行目から同じQ数字に整列されていないQ数字がある場合、
>
>★行の同じQ数字に合わせて整列させることはできますか?


'質問の意図をきちんと把握しきれていないのかも知れないですが・・・。
'2つ目以降は無視(削除)していいのであれば、
'以下の様な方法が考えられるかと思います。
'
'他にもいい方法があると思いますので、
'こんな方法もある程度に参考程度にして下さい。
'ここでは配列番号が、対応する列番号になる様にプログラムを組んであります。
'

Sub TEST()
  Dim Sort_Type() As String
  Dim Ary()

  '行の並べ替えの順を配列に格納
  'Keyは1行目
  For I = 1 To Cells(1, 256).End(xlToLeft).Column
    ReDim Preserve Sort_Type(1 To I)
    Sort_Type(I) = CStr(Cells(1, I).Value)
  Next

  '並べ替え実行は2行目から
  For I = 2 To Cells(65000, 1).End(xlUp).Row Step 1
    '配列要素の設定
    ReDim Ary(1 To 1, 1 To UBound(Sort_Type))
    '行内の列方向実行は最終列迄。
    For X = 1 To Cells(I, 256).End(xlToLeft).Column
      '対象セルが空白でなかった場合
      If Cells(I, X).Value <> "" Then
        FLG = False
        '並び替え候補配列内要素と比較し、同じものが存在すれば、
        'Ary配列の同一配列番号に値を格納
        For V = 1 To UBound(Sort_Type)
          If Sort_Type(V) = CInt(Cells(I, X).Value) Then
            Ary(1, V) = Sort_Type(V)
            FLG = True
            Exit For
          End If
        Next
        '全ての並び替え候補配列内要素と一致しなかった場合、
        '並び替え対象外の変数に値を格納
        If Not FLG Then
          Sort_Out = IIf(Sort_Out = "", Cells(I, X).Value, Sort_Out & "," & Cells(I, X).Value)
        End If
      End If
    Next
    並び替え範囲に値を配列より各セルに転写
    Range(Cells(I, 1), Cells(I, UBound(Sort_Type))) = Ary
    '並び替え範囲の一つ横の列に配列対象外となった値を格納
    Cells(I, UBound(Sort_Type) + 1) = Sort_Out
    Sort_Out = ""
  Next
  
End Sub

【20159】Re:並べ替え
お礼  やっしー  - 04/11/30(火) 3:27 -

引用なし
パスワード
   kazuさんへ

私の質問が悪かったです。すみませんでした。

にもかかわらずお答えいただきありがとうございました。

【20160】Re:並べ替え
質問  やっしー  - 04/11/30(火) 3:32 -

引用なし
パスワード
   1行目には、Q1, Q2_1, Q2_2, Q3, などのQを付与した数字を順においています。

2行目以降には「Q1 =2」「Q3 =2」「Q2_1=3」「Q2_2=4」などがバラバラに並んでいます。
ちなみに「Q1」「Q3」のイコール(=)はスペースをあけて「Q2_1」のイコールに揃えています。

2行目以降のバラバラに並んでいる「Q1 =3」「Q1 =2」「Q2_1=1」をそれぞれイコールの前がQ1ならQ1で、Q2_1ならQ2_1に、列ごとに整列させたいのです。

もちろん1行目の Q1, Q2_1, Q2_2, Q3 に揃えて。

★行目は、Q1 =2, Q2_1=3, Q2_2=4, Q3 =2
●行目は、Q1 =3, Q2_2=3, Q3 =1

というふうになっているので

例えば●行目のとき、「Q2_2=3」を横方向に一つのセルを飛ばして、1行目のQ2_2と書かれている列に移動し、Q3と書かれている列にQ3もまた、ひとつ横にセルをずらしたい。


もし、お分かりになるなら教えていただけないでしょうか?

よろしくお願いします。

【20161】Re:並べ替え
回答  ichinose  - 04/11/30(火) 8:20 -

引用なし
パスワード
   やっしー さん、kazu さん、おはようございます。

>1行目には、Q1, Q2_1, Q2_2, Q3, などのQを付与した数字を順においています。
>
>2行目以降には「Q1 =2」「Q3 =2」「Q2_1=3」「Q2_2=4」などがバラバラに並んでいます。
>ちなみに「Q1」「Q3」のイコール(=)はスペースをあけて「Q2_1」のイコールに揃えています。
>
>2行目以降のバラバラに並んでいる「Q1 =3」「Q1 =2」「Q2_1=1」をそれぞれイコールの前がQ1ならQ1で、Q2_1ならQ2_1に、列ごとに整列させたいのです。
>
>もちろん1行目の Q1, Q2_1, Q2_2, Q3 に揃えて。
>
>★行目は、Q1 =2, Q2_1=3, Q2_2=4, Q3 =2
>●行目は、Q1 =3, Q2_2=3, Q3 =1
>
>というふうになっているので
>
>例えば●行目のとき、「Q2_2=3」を横方向に一つのセルを飛ばして、1行目のQ2_2と書かれている列に移動し、Q3と書かれている列にQ3もまた、ひとつ横にセルをずらしたい。
1行目のデータとそれ以降の行の各列の「=」で区切られた左側の文字列を比較する
と言う意味で解釈しました。

'===============================================================
Sub main()
  Dim fundarray() As Variant
  On Error Resume Next
  With Application
   funcarray = .Transpose(.Transpose(Range(Cells(1, 1), Cells(1, Columns.Count).End(xlToLeft)).Value))
   End With
  For idx = 2 To ActiveSheet.UsedRange.Resize(, 1).Rows.Count
   For jdx = Cells(idx, Columns.Count).End(xlToLeft).Column To 1 Step -1
     Err.Clear
     f_val = Trim(Split(Cells(idx, jdx).Value, "=")(0))
     If Err.Number = 0 Then
      wk = Application.Match(f_val, funcarray, 0)
      If Not IsError(wk) Then
        tmp = Cells(idx, jdx).Value
        Cells(idx, jdx).Value = ""
        Cells(idx, wk).Value = tmp
        End If
      End If
     Next jdx
   Next idx
End Sub

簡単なテストをした限りでは、作動しています。
確認してみて下さい。

【20165】Re:並べ替え
発言  kazu  - 04/11/30(火) 10:19 -

引用なし
パスワード
   やっしー さん ,ichinose さん こんにちは。

ichinose さんのソースの方が高速そうなんで。。。不要かも知れませんが、
一応、自分のを変更したものをあげておきますね。


Sub TEST()
  Dim Sort_Type() As String
  Dim Ary()

  '行の並べ替えの順を配列に格納
  'Keyは1行目
  For I = 1 To Cells(1, 256).End(xlToLeft).Column
    ReDim Preserve Sort_Type(1 To I)
    Sort_Type(I) = CStr(Cells(1, I).Value)
  Next

  '並べ替え実行は2行目から
  For I = 2 To Cells(65000, 1).End(xlUp).Row Step 1
    '配列要素の設定
    ReDim Ary(1 To 1, 1 To UBound(Sort_Type))
    '行内の列方向実行は最終列迄。
    For X = 1 To Cells(I, 256).End(xlToLeft).Column
      Vlu = Cells(I, X).Value
      '対象セルが空白でなかった場合
      If Vlu <> "" Then
        FLG = False
        Tmp_Int = IIf(InStr(1, CStr(Vlu), "=") = 0, Len(Vlu), Tmp_Int - 1)
        '並び替え候補配列内要素と比較し、同じものが存在すれば、
        'Ary配列の同一配列番号に値を格納
        For V = 1 To UBound(Sort_Type)
          If Sort_Type(V) = Trim(Left(CStr(Vlu), Tmp_Int)) Then
            Ary(1, V) = Vlu
            FLG = True
            Exit For
          End If
        Next
        '全ての並び替え候補配列内要素と一致しなかった場合、
        '並び替え対象外の変数に値を格納
        If Not FLG Then
          Sort_Out = IIf(Sort_Out = "", Cells(I, X).Value, Sort_Out & "," & Cells(I, X).Value)
        End If
      End If
    Next
    '一旦行内の記載をクリア
    Rows(I).ClearContents
    '並び替え範囲に値を配列より各セルに転写
    Range(Cells(I, 1), Cells(I, UBound(Sort_Type))) = Ary
    '並び替え範囲の一つ横の列に配列対象外となった値を格納
    Cells(I, UBound(Sort_Type) + 1) = Sort_Out
    Sort_Out = ""
  Next
 
End Sub

【20189】Re:並べ替え
お礼  やっしー  - 04/12/1(水) 2:11 -

引用なし
パスワード
   kazuさんへ

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

とても感謝しております。

【20190】Re:並べ替え
質問  やっしー  - 04/12/1(水) 3:14 -

引用なし
パスワード
   ichinose さんへ

私が思っていたように実行することができました。

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

それで心苦しいのですが教えていただいたコードの説明を

していただけないでしょうか?

【20192】Re:並べ替え
発言  ichinose  - 04/12/1(水) 7:43 -

引用なし
パスワード
   ▼やっしー さん:
おはようございます。
>私が思っていたように実行することができました。
>
>ありがとうございました。
>
>それで心苦しいのですが教えていただいたコードの説明を
>
>していただけないでしょうか?
一箇所訂正も含めて
'==========================================================
Sub main()
  Dim fundarray() As Variant
' 一行目のセルの値を格納する配列
  On Error Resume Next
  With Application
   fundarray() = .Transpose(.Transpose(Range(Cells(1, 1), Cells(1, Columns.Count).End(xlToLeft)).Value))
'  一行目のセルの値を格納する Match関数で使用したいので
'  Transposeを2回実行して1次元配列に格納しています
'  funcarrayとなっていましたね 訂正して下さい
   End With
  For idx = 2 To ActiveSheet.UsedRange.Resize(, 1).Rows.Count
'   2行目から使用されている行までのリピート処理
   For jdx = Cells(idx, Columns.Count).End(xlToLeft).Column To 1 Step -1
'    行の各列を列番号の大きい方から列番号が1になるまでのリピート処理
     Err.Clear 'エラークリア
     f_val = Trim(Split(Cells(idx, jdx).Value, "=")(0))
'    セルのデータを"="で分割した最初のデータをf_valに格納
'    この際、セルが未入力の場合、エラーが発生するので
     If Err.Number = 0 Then 'セルの値が未入力でなければ
      wk = Application.Match(f_val, fundarray(), 0)
'      一行目のセルの値を格納した配列内をf_valで検索あれば、
'        wkには列番号に相当する値が返る
'      ここも funcarrayとなっていましたね 訂正して下さい
      If Not IsError(wk) Then '検索した結果見つかった場合
        tmp = Cells(idx, jdx).Value
        '元の位置のセルの値を退避
        Cells(idx, jdx).Value = ""
        '元の位置のセルをクリア
        Cells(idx, wk).Value = tmp
        '新位置のセルに値代入
        End If
      End If
     Next jdx
   Next idx
End Sub

以上です。

【20203】Re:並べ替え
お礼  やっしー  - 04/12/1(水) 13:08 -

引用なし
パスワード
   ichinoseさんへ

こんにちは。

ありがとうございます。

感謝してます。

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