[[20120521121359]]　『③　自動挿入＆コピー、ペースト』（ライド）　ページの最後に飛ぶ

『③　自動挿入＆コピー、ペースト』（ライド）

 以前下記の質問をして
 (Bun)さんに教えていただいたように
 やっていたのですが
 表が少し変わったため
 自分で試行錯誤やってみたのですが
 うまくいきません
 どの部分をどのように変えればうまくいきますでしょうか？

  Sheet1
    A   B   C   D   E    F     G      H    I    J    k
 1  a       A　    あ          F                     2
 2  a       A　    あ          JT                   10
 3  c       C　    い          F                     3
 4  c       C　    い          TLC                   2
 5  e       E　    う          F                     1
 6  f       F　    え          F                     4
 7  f       F　    え          TXX                   5

 ↓↓↓↓　このようにしたいです

 Sheet2
     A   B   C   D   E    F     G     H     I     J     K
 1   a       A　    あ          F                       2
 2   a       A　    あ          F                       2
 3   a       A　    あ          JT                     10
 4   c       C　    い          F                       3
 5   c       C　    い          F                       3
 6   c       C　    い          F                       3
 7   c       C　    い          TLC                     2
 8   c       C　    い          TLC                     2
 9   e       E　    う          F                       1
 10  f       F　    え          F                       4
 11  f       F　    え          F                       4
 12  f       F　    え          F                       4
 13  f       F　    え          F                       4
 14  f       F　    え          TXX                     5
 15  f       F　    え          TXX                     5
 16  f       F　    え          TXX                     5
 17  f       F　    え          TXX                     5
 18  f       F　    え          TXX                     5

 Ａ列に宛先　C列に商品No　E列に受注名　G列に商品名　K列に数量　の表で(H-Jにもデータあり）
 数量の数の分（実際はその数-1）　列を挿入し
 その宛先・商品No・受注名・商品名・数量を表示させたいです。
 別のｼｰﾄに表示させたいです　
 そして　ひとつ条件があり商品名が「F」と「頭文字がＴ］の場合
 だけ　このようにしたいのです。

 --------------------------------------------------------------------------------

 質問させていただきます
 どなたか　よろしくお願いいたします

 Excel2007,Windows 7

 Ａ列に宛先　C列に商品No　E列に受注名　Ｆ列に商品名　Ｇ列に数量　の表で
 数量の数の分（実際はその数-1）　列を挿入し
 その宛先・商品No・受注名・商品名・数量を表示させたいです。
 別のｼｰﾄに表示させたいです　
 そして　ひとつ条件があり商品名が「F」と「頭文字がＴ］の場合
 だけ　このようにしたいのです。
 できればVBAでできればと思っております

 Sheet1
    A   B   C   D   E    F     G
 1  a       A　    あ   F      2
 2  a       A　    あ   JT    10
 3  c       C　    い   F      3
 4  c       C　    い   TLC    2
 5  e       E　    う   F      1
 6  f       F　    え   F      4
 7  f       F　    え   TXX    5

 ↓↓↓↓　このようにしたいです

 Sheet2
     A   B   C   D   E    F     G
 1   a       A　    あ   F      2
 2   a       A　    あ   F      2
 3   a       A　    あ   JT    10
 4   c       C　    い   F      3
 5   c       C　    い   F      3
 6   c       C　    い   F      3
 7   c       C　    い   TLC    2
 8   c       C　    い   TLC    2
 9   e       E　    う   F      1
 10  f       F　    え   F      4
 11  f       F　    え   F      4
 12  f       F　    え   F      4
 13  f       F　    え   F      4
 14  f       F　    え   TXX    5
 15  f       F　    え   TXX    5
 16  f       F　    え   TXX    5
 17  f       F　    え   TXX    5
 18  f       F　    え   TXX    5

 前回とレイアウトが変わったんだね。

 前回の追加質問なら

 If c.Offset(, 1).Value = "あ" Then x = c.Offset(, 2).Value

 これを

 If c.Offset(, 1).Value = "あ" Or Left(c.Offset(, 1).Value) = "T" Then x = c.Offset(, 2).Value

 にすればよかったんだけど、それで、今回の件、応用できるかな？

 (ぶらっと)

 なんとか、がんばって応用してみればいいと思うけど、ちょっと要件がかわっているところもあるようなので。

 Sub Sample()
    Dim z As Long
    Dim v As Variant
    Dim c As Range
    Dim k As Long
    Dim x As Long
    Dim y As Long
    Dim n As Long
    Dim j As Long
    With Sheets("Sheet1")
        z = WorksheetFunction.Sum(.UsedRange.Columns(7))    'G列
        n = .UsedRange.Columns.Count
        ReDim v(1 To z, 1 To n)
        For Each c In .UsedRange.Columns(6).Cells           'F列
            x = 1
            If c.Value = "F" Or Left(c.Value, 1) = "T" Then x = c.Offset(, 1).Value
            For y = 1 To x
                k = k + 1
                For j = 1 To n
                    v(k, j) = c.EntireRow.Cells(1, j).Value
                Next
            Next
        Next
    End With

    With Sheets("Sheet2")
        .Cells.ClearContents
        .Range("A1").Resize(k, UBound(v, 2)).Value = v
        .Select
    End With

    MsgBox "処理終了"

 End Sub

 (ぶらっと)

 v(k, j) = c.EntireRow.Cells(1, j).Value
 この部分でとまってしまいます((+_+))

 （ライド）

 こんなのでも？

 Option Explicit

 Public Sub Sample_2()

    'Listのデータ列数（A列～G列）
    Const clngColumns As Long = 7

    Dim i As Long
    Dim j As Long
    Dim lngRows As Long
    Dim rngList As Range
    Dim rngResult As Range
    Dim vntData As Variant
    Dim vntMark As Variant
    Dim strProm As String

    'Listの先頭セル位置を基準とする
    Set rngList = Worksheets("Sheet1").Range("A1")

    '結果出力の先頭セル位置を基準とする
    Set rngResult = Worksheets("Sheet2").Range("A1")

    '行を増やす条件を設定
    vntMark = Array("F", "T*")

    '画面更新を停止
    Application.ScreenUpdating = False

    'Shet2のデータをクリア
    rngResult.Parent.UsedRange.ClearContents

    With rngList
        '行数の取得
        lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row + 1
        If lngRows <= 1 And IsEmpty(.Value) Then
            strProm = "データが有りません"
            GoTo Wayout
        End If
        'F、G列データを配列に取得
        vntData = .Offset(, 5).Resize(lngRows, 2).Value
        '全データをSheet2にCopy
        .Resize(lngRows, clngColumns).Copy Destination:=rngResult
    End With

    With rngResult
        '最終列の後ろに行番号を出力
        With .Offset(, clngColumns)
            .Value = 1
            .Resize(lngRows).DataSeries Rowcol:=xlColumns, Type:=xlLinear, _
                    Date:=xlDay, Step:=1, Trend:=False
        End With
        'F列に就いて先頭～最終まで繰り返し
        For i = 1 To lngRows
            'Fの文字か頭にTが付く文字を確認
            For j = 0 To UBound(vntMark)
                If vntData(i, 1) Like vntMark(j) Then
                    Exit For
                End If
            Next j
            '一致した場合
            If j <= UBound(vntMark) Then
                '転記数が1以上の場合
                If vntData(i, 2) - 1 > 0 Then
                    '最終行の下に転記数分Copy
                    .Offset(i - 1).Resize(, clngColumns + 1).Copy _
                            Destination:=.Offset(lngRows + 1 - 1).Resize(vntData(i, 2) - 1)
                    '最終行を更新
                    lngRows = lngRows + vntData(i, 2) - 1
                End If
            End If
        Next i
        'データを行番号をKeyに整列
        .Resize(lngRows, clngColumns + 1).Sort _
                Key1:=.Offset(, clngColumns), Order1:=xlAscending, _
                Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
                Orientation:=xlTopToBottom, SortMethod:=xlStroke
        '行番号を消去
        .Offset(, clngColumns).EntireColumn.ClearContents
    End With

    strProm = "処理が完了しました"

 Wayout:

    '画面更新を再開
    Application.ScreenUpdating = True

    Set rngList = Nothing
    Set rngResult = Nothing

    MsgBox strProm, vbInformation

 End Sub

 (Bun)

 >v(k, j) = c.EntireRow.Cells(1, j).Value
 >この部分でとまってしまいます((+_+))

 ん？？

 少なくともアップされたデータで、アップしたコードを動かすと正常に処理されるけどなぁ・・
 エラーで止まったときの、v(k,j) の v あたり、それと、k と j にマウスをあてたとき、何がポップアップされるか教えてくれる？

 それとエラーメッセージはなんだった？

 追伸）　アップされた例のとおり、１行目からデータだよね。
　もし、１行目がタイトル行で、データが、すべて　Ｆ　ないしは　頭が Ｔならエラーになる可能性はあるけど。
　それならそれで、コードをなおせばいいんだけどね。

 (ぶらっと)

 （ぶらっと）さんへ
 v(k,j)=<インデックスが有効範囲にありません。>
 となっています

 1行目からデータです
 データがすべてＦ　ないしは　頭が Ｔではありません

 （Bun)さんへ
 できました　意味が全く理解できませんでしたが・・・(?_?)

 （ライド）

 解決ということで祝着。なんだけどねぇ・・・
 こちらでアップされたデータを下に、Bunさんのコードを動かしても、もちろん、正常終了、私のコードでも正常終了。
 両者の結果も、全く同じ。

 私のコードは、転記用配列の行数を「けちって」Sheet1のG列の数値の合計数に限定しているので
 そのあたりで、実際のシートの
 G列に、私が思いつかない形の数値が入っているのかもしれない。

 とすれば、もう用済みだろうけど、私のコードの
 ReDim v(1 To z, 1 To n)
 これを
 ReDim v(1 To .Rows.Count, 1 To n)
 こうしてもらえれば、たぶん、うまくいくと思う。

 (ぶらっと)

コメント返信：

[ 一覧(最新更新順) ]

[[20120521121359]] 『③ 自動挿入＆コピー、ペースト』（ライド） ページの最後に飛ぶ

[[20120521121359]]　『③　自動挿入＆コピー、ペースト』（ライド）　ページの最後に飛ぶ