[[20120503170237]]　『セルの移動』（初心者）　ページの最後に飛ぶ

『セルの移動』（初心者）

A列に下記のようにデータがあります。
A1：1111aaaa
A2：1111bbcc
A3：1111bbcc
A4：1111cbgd
A5：2222aacb
A6：2222aadt
A7：2222aasv
A8：3333aasc
　　　・
　　　・
　　　・

これをマクロ？で、次のように移動したいです。

A1：1111aaaaはそのまま→B1：1111bbcc→C1:1111cbgd（A3：1111bbccは、A2と重複するので不要）
A2:2222aacb→B2：2222aadt→C2：2222aasv

A3：3333aasc

　　・
　　・　　
　　・
　何をどうしていいのか全く分かりません。
　どなたかご教授をお願いいたします。

 excel2010
 windows7

 質問される側も、何をどうしたいのか、まったく見えないんだけど？

 >A1：1111aaaaはそのまま→B1：1111bbcc→C1:1111cbgd（A3：1111bbccは、A2と重複するので不要）

 こう書いていると言うことは 1111aaaa が　1111bbcc　になるルールというか規則というか、そういうものがあるんだろうね。
 当然 1111bbcc が　1111cbgd になるルールも。

 一生懸命考えたけどわからないなぁ・・・

 >A3：1111bbccは、A2と重複するので不要

 この日本語の意味もわからないし・・・

 あっ！わかったみたい。
 縦に並んでいるものを重複をなくしたうえで３つずつのセットで並べていきたいということかな。

 (ぶらっと)

 できるだけ、凝らずに、基本的な構文で書いてみた。
フィルターオプション（2010のメニューでは　フィルタの詳細設定）機能を使用。
また、できあがりの形（３行を１行にした　●行３列）の配列にパッキングしたうえで
最後にシートに書き戻している。

 Sub Sample()
    Dim v() As String
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim z As Long

    Application.ScreenUpdating = False

    'フィルターオプションでA列の重複を排除してB列に転記
    Range("A1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove   'フィルターオプション用のタイトル行挿入
    Range("A1").Value = "Dummy"                                             'タイトル項目名　何でもOK
    Columns("B").ClearContents                                              '作業列
    Columns("A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("B1"), Unique:=True    '重複排除してB列に
    Range("B1").Delete Shift:=xlUp                                          '挿入したタイトル行の削除

    'B列のユニークなデータを３個ごと１行にパッキング
    z = Range("B" & Rows.Count).End(xlUp).Row
    If z Mod 3 > 0 Then z = (z \ 3 + 1) * 3

    ReDim v(1 To z \ 3, 1 To 3)
    j = 1   'パッキングした列番号
    k = 1   'パッキングした行番号
    For i = 1 To z
        v(k, j) = Cells(i, "B").Value
        j = j + 1
        If j > 3 Then   '３つパッキングしたら次の行
            j = 1
            k = k + 1
        End If
    Next

    Columns("A:C").ClearContents
    Range("A1").Resize(UBound(v, 1), UBound(v, 2)).Value = v

    Application.ScreenUpdating = True
    MsgBox "処理完了"

 End Sub

 (ぶらっと)

 こちらのコードのほうが理解しやすいかもしれない
 フィルターオプションと行列を入れ替えてのコピペで処理。

 Sub Sample2()
    Dim i As Long
    Dim k As Long
    Dim z As Long

    Application.ScreenUpdating = False

    'フィルターオプションでA列の重複を排除してD列に転記
    Range("A1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove   'フィルターオプション用のタイトル行挿入
    Range("A1").Value = "Dummy"                                             'タイトル項目名　何でもOK
    Columns("D").ClearContents                                              '作業列
    Columns("A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("D1"), Unique:=True    '重複排除してB列に
    Range("D1").Delete Shift:=xlUp                                          '挿入したタイトル行の削除

    'D列のユニークなデータを３個ごと１行に行列を入れ替えてA:C列にコピーペースト
    z = Range("D" & Rows.Count).End(xlUp).Row
    Columns("A:C").ClearContents
    For i = 1 To z Step 3
        k = k + 1
        Range("D" & i).Resize(3).Copy
        Range("A" & k).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        Application.CutCopyMode = False
    Next

    Columns("D").ClearContents                                              '作業列
    Application.ScreenUpdating = True
    MsgBox "処理完了"

 End Sub

 (ぶらっと)

ぶらっと様

ありがとうございます。
説明が悪く、大変申し訳ありません。

左から4文字が一つの情報群（主コード）右から4文字が、
もう一つの情報群（サブコード）です。

上に重複するものを記載しましたが、
もう一度確認したところ、データ取扱い上、
重複するものはありません。
申し訳ありません。

もう一度、ご説明させていただきますと、

A1：1111aaaa
A2：1111bbcc
A3：1111cbgd
A4：1111hbfd
A5：2222aacb
A6：2222aasv
A7：3333aasc
A8：4444aadf
　　　・
　　　・
　　　・
A1：1111aaaa はそのまま
B1：1111bbcc に移動します。
C1：1111cbgdに移動します。
D1：1111hbfdに移動します。
1行目にこれらをまとめるのは、主コードが1111だからです。
A2：2222aacb、B2：2222aasv と移動します。
主コードが2222で第2番目だからです。

A3：3333aascに移動します。主コードが3番目だからです。

1111と第何行目かは、直接関係ありません。
9999が、9行目とは限らないという意味です。

主コードの並び順で行を決めていきます。

A1からA1000くらいまでデータが入っているものとします。

説明がうまくできず、申し訳ございませんが、
ご確認をお願いします。

（初心者）

 >説明が悪く、大変申し訳ありません。

 説明が悪いんじゃなく、全く違う説明だったということ（笑）
 ともあれ以下。少し重いかもしれないし、初心者にはDictionaryというものが見慣れないものかもしれないけど。
 通常のループ処理でも書けると思うけど、面倒なのでとりあえず。

 Sub Sample2()
    Dim dic As Object
    Dim v() As Variant
    Dim z As Long
    Dim c As Range
    Dim i As Long
    Dim j As Long
    Dim key As String

    Set dic = CreateObject("Scripting.Dictionary")
    z = Range("A" & Rows.Count).End(xlUp).Row       'データ最終行
    ReDim v(1 To z, 1 To Columns.Count)             'できあがりのイメージを納める配列。余裕を持って（持ちすぎ？）準備。

    For Each c In Range("A1:A" & z)
        key = Left(c.Value, 4)
        If Not dic.exists(key) Then
            dic(key) = 0
            i = i + 1
        End If
        j = dic(key) + 1
        If j <= Columns.Count Then v(i, j) = c.Value
        dic(key) = j
    Next
    Range("A1").Resize(UBound(v, 1), UBound(v, 2)).Value = v
    MsgBox "処理完了"

 End Sub

 (ぶらっと)

 でも、やっぱり、こっちのほうがわかりやすいよね。

 Sub Sample3()
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim v As Variant
    Dim oKey As String
    Dim nKey As String

    Application.ScreenUpdating = False

    v = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value        'A列のデータを配列に格納
    Cells.ClearContents                                             'シートをクリア

    For i = 1 To UBound(v, 1)       '配列の１行目から最終行まで１つずつ処理
        nKey = Left(v(i, 1), 4)     'データの最初の４桁がキー
        If oKey <> nKey Then        'キーの比較
            j = 0                   '転記列番号リセット
            k = k + 1               '転記行番号
        End If
        j = j + 1                   '転記列番号
        If j <= Columns.Count Then Cells(k, j).Value = v(i, 1)  'シートの列がありえない番号になればスキップ
        oKey = nKey                 'キーの更新
    Next

    Application.ScreenUpdating = True
    MsgBox "処理完了"

 End Sub

 (ぶらっと)

ぶらっと様

 説明が悪いんじゃなく、全く違う説明だったということ（笑）
 →申し訳ありません。
 信じられないほどうまくいきました。
 かなり時間をかけていた作業でしたが、マクロをできれば本当に仕事が変わりますね。
 ありがとうございました。
 コードも勉強させていただきます。

　（初心者）

コメント返信：

[ 一覧(最新更新順) ]

[[20120503170237]] 『セルの移動』（初心者） ページの最後に飛ぶ

[[20120503170237]]　『セルの移動』（初心者）　ページの最後に飛ぶ