エクセルのVBAについて質問です。


並び替えの処理を行い、データの埋め込み作業を自動で行うプログラムを作成したいと考えております。

プログラムを行うデータですが、以下のような状況です。(ページの続きが、今回作成したいプログラムの流れとなります。)

http://oskuni7.sakura.ne.jp/hatena/question6/hatena.htm

データ列M,Nの値を条件として、埋め込み用データの列Uと列Vのデータを自動で埋め込むプログラムです。


前回似た様なプログラムを作成して頂いたのですがその際の質問は以下になります。

http://q.hatena.ne.jp/1229390550

そこで教えていただいたプログラムのスクリプトは以下になります。

http://oskuni7.sakura.ne.jp/hatena/question4/saisyupin.txt

今回前回と違うところは

★埋め込み用のデータを削除しない。

★データを埋め込んだ後、データの列Mを第一条件で降順で並び替え、データ列Nを第二条件の昇順で並び替える。

所です。

お手数をおかけしますが時間があるかたでプログラムを作成できるかたおりましたらよろしくお願いいたします。

回答の条件
  • 1人2回まで
  • 登録:2009/01/08 20:44:22
  • 終了:2009/01/10 23:05:56

ベストアンサー

id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912009/01/08 23:01:36

ポイント100pt

失礼しました。前回とは全く異なる処理だったのですね。

下記でどうでしょうか。

Sub Aiomock2()
    Const DATA_START_LINE = 4

    Dim i As Long
'--- Step 1 ソート
    Range("A4:AA65535").Sort _
    Key1:=Range("N4"), Order1:=xlAscending, _
    Key2:=Range("M4"), Order2:=xlAscending, _
    Header:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
    
    Dim lastRow As Long
    lastRow = Range("AF" & Rows.Count).End(xlUp).Row
    
'--- Step 2 データ転記
    Dim pCode As String
    Dim bOverWrite As Boolean
    Dim srcRow As Long
    For i = DATA_START_LINE To lastRow
        If Cells(i, "N").Value = Cells(i + 1, "N").Value _
        And Cells(i, "M").Value = 0 _
        And Cells(i + 1, "M").Value = 1 Then
            Cells(i + 1, "U").Value = Cells(i, "U").Value
            Cells(i + 1, "V").Value = Cells(i, "V").Value
        End If
    Next

'--- ★★★Step 3 再ソート【変更部分】
    Range("A4:AG65535").Sort _
    Key1:=Range("M4"), Order1:=xlDescending, _
    Key2:=Range("N4"), Order2:=xlAscending, _
    Header:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
End Sub
id:aiomock

ご回答ありがとうございます。

再度実行してみましたが、データがまた埋め込まれない状況でした。

原因が少しわからないです。。

2009/01/09 00:05:53

その他の回答(2件)

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912009/01/08 21:24:37

変更したいのは最後の処理の部分だけだのようですが、下記でご希望に添いますか。

Sub Aiomac再出品()
    Const DATA_START_LINE = 4

    Dim i As Long
'--- Step 1 ソート
    Range("A4:AG65535").Sort _
    Key1:=Range("AG4"), Order1:=xlAscending, _
    Key2:=Range("AF4"), Order2:=xlAscending, _
    Header:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
    
    Dim lastRow As Long
    lastRow = Range("AF" & Rows.Count).End(xlUp).Row
    
'--- Step 2 データ転記
    Dim pCode As String
    Dim bOverWrite As Boolean
    Dim srcRow As Long
    For i = DATA_START_LINE To lastRow
        If Cells(i, "AG").Value = pCode Then
            If bOverWrite = True And Cells(i, "AF") = 1 Then
                Range("A" & srcRow).Resize(1, 31).Copy _
                    Destination:=Range("A" & i).Resize(1, 31)
                Cells(i, "AH") = "再出品"
            End If
        Else
            If Cells(i, "AF").Value = 0 Then
                bOverWrite = True
                pCode = Cells(i, "AG").Value
                srcRow = i
            Else
                bOverWrite = False
            End If
        End If
    Next

'--- ★★★Step 3 再ソート【変更部分】
    Range("A4:AG65535").Sort _
    Key1:=Range("M4"), Order1:=xlDescending, _
    Key2:=Range("N4"), Order2:=xlAscending, _
    Header:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
End Sub

仕様と異なる部分がありましたら、コメントください。

id:aiomock

ご回答ありがとうございます。

試してみます。

2009/01/08 22:06:47
id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912009/01/08 23:01:36ここでベストアンサー

ポイント100pt

失礼しました。前回とは全く異なる処理だったのですね。

下記でどうでしょうか。

Sub Aiomock2()
    Const DATA_START_LINE = 4

    Dim i As Long
'--- Step 1 ソート
    Range("A4:AA65535").Sort _
    Key1:=Range("N4"), Order1:=xlAscending, _
    Key2:=Range("M4"), Order2:=xlAscending, _
    Header:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
    
    Dim lastRow As Long
    lastRow = Range("AF" & Rows.Count).End(xlUp).Row
    
'--- Step 2 データ転記
    Dim pCode As String
    Dim bOverWrite As Boolean
    Dim srcRow As Long
    For i = DATA_START_LINE To lastRow
        If Cells(i, "N").Value = Cells(i + 1, "N").Value _
        And Cells(i, "M").Value = 0 _
        And Cells(i + 1, "M").Value = 1 Then
            Cells(i + 1, "U").Value = Cells(i, "U").Value
            Cells(i + 1, "V").Value = Cells(i, "V").Value
        End If
    Next

'--- ★★★Step 3 再ソート【変更部分】
    Range("A4:AG65535").Sort _
    Key1:=Range("M4"), Order1:=xlDescending, _
    Key2:=Range("N4"), Order2:=xlAscending, _
    Header:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
End Sub
id:aiomock

ご回答ありがとうございます。

再度実行してみましたが、データがまた埋め込まれない状況でした。

原因が少しわからないです。。

2009/01/09 00:05:53
id:airplant No.3

airplant回答回数220ベストアンサー獲得回数492009/01/10 00:14:37

ポイント100pt

ポイントは不要です。

横から失礼します。Mookさんすみません。

動いていないのは下記部分と思います。

'    lastRow = Range("AF" & Rows.Count).End(xlUp).Row
    lastRow = Range("AA" & Rows.Count).End(xlUp).Row

' なお、開始行が4行目以外のときには、下記の部分の4を直す
    Const DATA_START_LINE = 4

    Range("A4:AA65535").Sort _
    Key1:=Range("N4"), Order1:=xlAscending, _
    Key2:=Range("M4"), Order2:=xlAscending, _


余談ですが、この操作は結局列Nをキーにして、元データの値を2つ持って来たいということですね?

元データがダイナミックに変わるのかどうか不明ですが、通常はvlookup関数で十分にできると思います。


拙作ですが、こちらもご参考まで。

http://d.hatena.ne.jp/airplant/20070808/1186598203

http://d.hatena.ne.jp/airplant/20070612/1181669879

id:aiomock

ご回答ありがとうございます。

2009/01/10 03:37:27
  • id:aiomock
    Mook さん

    プログラム実行してみました。

    実行してみたところデータの受け渡しのところがうまくいっておりません。

    埋め込み先データ(列Mが1)に埋め込み用データ(列Mが0)が入っていない状況です。

    埋め込み用データの列UとVのデータを埋め込み先データの列UとVに移動していただけるよう

    お手数をおかけしますがよろしくお願いいたします。


  • id:Mook
    すみませんが、もう少し調べて明日の夜回答します。

    他の方の回答があるかもしれませんが、解決したら終了いただいて結構です。
    その場合、ポイントは不要です。
  • id:aiomock
    申し訳ありません。。

    お手数をおかけしますがよろしくお願いいたします。
  • id:Mook
    airplantさん、
    駄コードのサポートありがとうございました。
    アドレスの変更にいろいろと不備が残っていたようです。

    いつもはできるだけ動作検証しているのですが、今回くらいだったら動くだろう
    と思ったら・・・。
    やはり手を抜いてはいけませんね。

    どちらにせよ回答上限で回答できなかったので、助かりました。
  • id:aiomock
    Mook さん

    プログラム実行されました。

    私の行数確認という単純間違いでした。

    本当に申し訳ないです。。。

    次回より確認をより確実にさせていただければと思いました。
  • id:aiomock
    airplant さん

    ご丁寧にご回答いただきありがとうございます。

    VLOOK関数をより多用させていただこうかと思います。

    この度はご回答ありがとうございます。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません