[[20141021160808]]　『データを種別毎に、別シートに振り分けできないで』（pomy）　ページの最後に飛ぶ

『データを種別毎に、別シートに振り分けできないでしょうか。』（pomy）

はじめまして。

マクロ初心者です。
調べつくして下記の様な　『Ａ列』に『1』が入力された行を明細シートへ転記
できるよう作ったのですが、内容の変更を要求され困っています。。。

やりたい事は・・・

『Ａ列』に『1』が入力され、尚且つ『Ｄ列』の種別毎に振り分け別シートに
振り分けたいです。

　例）1列：１　Ｄ列：Ａ　の場合　→『Ａ明細』シートへ転記
　　　1列：１　Ｄ列：Ｂ　の場合　→『Ｂ明細』シートへ転記
　　　1列：１　Ｄ列：Ｃ　の場合　→『ＣＤ明細』シートの1行～50行へ転記
　　　1列：１　Ｄ列：Ｄ　の場合　→『ＣＤ明細』シートの51行～100行へ転記

　※種別（Ｃ・Ｄ）は、件数が最大５０件の為、一つのシートにまとめたいです。

解る方おられましたらご指南よろしくお願い致します。

－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub 転記()

'リストシート：『Ａ列』に『1』が入力された行を明細シートへ転記

Sheets("明細").Range("A2:N5000").ClearContents

Dim i, lastRow As Long
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lastRow
If Cells(i, 1) = "1" Then
Rows(i).Copy Sheets("明細").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
End If
Next i

MsgBox "転記完了"

End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

＜使用 Excel：Excel2010、使用 OS：Windows7 ＞

2行目から消しているので、タイトル行があって、転記先は2行目からではないかと推測。

 Sub 転記()
    Dim i As Long
    Dim j As Long
    Dim iR(3) As Long
    Dim vw1 As Variant
    Dim vw2 As Variant

    vw1 = Array("Ａ", "Ｂ", "Ｃ", "Ｄ")
    vw2 = Array("Ａ明細", "Ｂ明細", "ＣＤ明細", "ＣＤ明細")

    Application.ScreenUpdating = False

    For i = 0 To 2
        iR(i) = 2
        Sheets(vw2(i)).Range("A2:N5000").ClearContents
    Next i
    iR(3) = 53

    For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        If Cells(i, "A").Text = "1" Then
            For j = 0 To 3
                If Cells(i, "D").Value = vw1(j) Then
                    With Sheets(vw2(j))
                        Rows(i).Copy .Cells(iR(j), 1)
                        iR(j) = iR(j) + 1
                    End With
                    Exit For
                End If
            Next j
        End If
    Next i

    Application.ScreenUpdating = True
    MsgBox "転記完了", vbInformation, "終了"
End Sub
（???） 2014/10/21(火) 17:04

???様
先日お礼のコメントを入力したつもりでしたが、掲載されていませんでした。
申し訳ありません。
改めて、ありがとうございました。

何度もすみません。

シートを追加したくて、下記の部分に其々『種別名と、シート名』を追加しましたが
転記できませんでした。

他にどこを修正すれば良いでしょうか？

修正した箇所

 vw1 = Array("Ａ", "Ｂ", "Ｃ", "Ｄ", "Ｅ")
 vw2 = Array("Ａ明細", "Ｂ明細", "ＣＤ明細", "ＣＤ明細", "Ｅ明細")
（pomy） 2014/10/23(木) 09:26

iR という配列宣言も、1つ増やしてください。
新しく追加したシートの行位置は iR(4) になりますので、初期値としてここに 2 を代入しておいてください。
増やしたシート、Sheets(vw2(4)) のクリアも必要になるでしょう。
更に、j のループは 0～3 でしたが、これも1つ増やして、0～4 でループさせてください。
（???） 2014/10/23(木) 12:27

お返事ありがとうございます。

下記の様に修正してみたのですが、エラーが出てしまいます。
何故でしょうか？？？

因みにＡとＢは正しく転記されますが、ＣＤ明細には種別Ｄが転記されず
Ｅ明細は、種別Ｅが転記されるべき２行以降が空欄で、
種別Ｆが転記されるべき５３行以降に種別Ｅが転記されています。
種別Ｆは転記されていません。

－－－－－－－
Sub 転記()

    Dim i As Long
    Dim j As Long
    Dim iR(4) As Long
    Dim vw1 As Variant
    Dim vw2 As Variant
    vw1 = Array("Ａ", "Ｂ", "Ｃ", "Ｄ", "Ｅ", "Ｆ")
    vw2 = Array("Ａ明細", "Ｂ明細", "ＣＤ明細", "ＣＤ明細", "Ｅ明細","Ｅ明細")
    Application.ScreenUpdating = False
    For i = 0 To 2
        iR(i) = 2
        Sheets(vw2(i)).Range("A2:N5000").ClearContents
    Next i
    iR(4) = 53
    For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        If Cells(i, "A").Text = "1" Then
            For j = 0 To 4
                If Cells(i, "D").Value = vw1(j) Then
                    With Sheets(vw2(j))
                        Rows(i).Copy .Cells(iR(j), 1)       ←この部分でエラーが出てしまいます。
                        iR(j) = iR(j) + 1
                    End With
                    Exit For
                End If
            Next j
        End If
    Next i
    Application.ScreenUpdating = True
    MsgBox "転記完了", vbInformation, "終了"
End Sub
－－－－－－－
（pomy） 2014/10/23(木) 15:08

iR(3) = 53 を消してしまったからエラーになっていますね。出力に0行目は指定できないので。
あと、Ｅ明細が2つになっているので、更に配列は1つ増やして、iR(5) としないと。ループも0～5。

iR(3) = 53
iR(4) = 2
iR(5) = 53
（???） 2014/10/23(木) 15:28

できました！！

本当に、本当に、
ありがとうございました!!!!!!
（pomy） 2014/10/23(木) 16:38

コメント返信：

[ 一覧(最新更新順) ]

[[20141021160808]] 『データを種別毎に、別シートに振り分けできないで』（pomy） ページの最後に飛ぶ

[[20141021160808]]　『データを種別毎に、別シートに振り分けできないで』（pomy）　ページの最後に飛ぶ