[[20080716113841]]　『またまた分からなくなってしまいました。助けて～』（nori）　ページの最後に飛ぶ

 『またまた分からなくなってしまいました。助けて～』（nori）
 教えていただき、動いていたのですが、これを使う同僚の方から変更して欲しいとの
話があり、変更したところ、動作がおかしくなってしまいました。
 症状は、B8からデータを入れ、CommandButton1をクリックすると同名のシートに転記する様になっております。
 しかし、変更後、8行目に入っているデータがA社への注文内容、9行目がB社への注文
内容、10行目にC社への注文内容が入っているとすると、
ボタンを押すと、A社への注文内容は正確にA社名のシートに転記されます。
しかし、B社、C社名のシートにはB社、C社への注文内容の外にシートの先頭行に
A社への注文内容も転記されてしまいます。この症状を何とか改善したいと思うのです
い、いろいろやってみたのですが、うまく行きません。
改善策を教えてください。よろしくお願いいたします。

 Private Sub CommandButton1_Click()

 Dim LastRow1 As Long  '元データの最終行
 Dim LastRow2 As Long  '作業用シート「Temp」のデータの最終行
 Dim LastRow3 As Long
 Dim SheetCheck As Integer
 Dim Rng As Range
 Dim Sh As Worksheet
 Dim WS1 As Worksheet
 Dim WS2 As Worksheet

 Set WS1 = Sheets("入力シート")

 'データの最終行を取得
 LastRow1 = WS1.Range("B65536").End(xlUp).Row  '←ここで最初にデータ行を取得する

 If LastRow1 < 8 Then Exit Sub                 '←ここでデータの存在を確認する
 Application.ScreenUpdating = False '画面の更新を停止

 '作業用シートの挿入
 'Worksheets.Add(after:=WS1).Name = "Temp"
 Set WS2 = Sheets("Temp")

 '重複する業者名を除いて作業用シート「Temp」に抽出　'←フィルターはB7を含める
 WS1.Range("B7:B" & LastRow1).AdvancedFilter _
     Action:=xlFilterCopy, CopyToRange:=WS2.Range("A1"), _
     Unique:=True

 '作業用シート「Temp」のデータの最終行を取得
 LastRow2 = WS2.Range("A65536").End(xlUp).Row

 '抽出した各業者毎に処理を繰り返す
 For Each Rng In WS2.Range("A2:A" & LastRow2)      '←TmpのA2から開始する

    '業者名のシートの有無をチェック
    SheetCheck = 0
    For Each Sh In Worksheets
        If Sh.Name = Rng.Value Then
            SheetCheck = 1
            Exit For
        End If
    Next Sh
    If SheetCheck = 1 Then  '業者名のシートがあった場合
        '業者名シートの入力されているデータの最後を求める
        LastRow3 = Sheets(Rng.Value).Range("B65536").End(xlUp).Row
        '業者名毎にデータを抽出
        WS1.Range("B7").AutoFilter Field:=2, Criteria1:=Rng.Value
        '抽出したデータに対応する業者名のシートにデータをコピー
        WS1.Range("D8:K" & LastRow1).Copy
        Sheets(Rng.Value).Range("B" & LastRow3 + 1).PasteSpecial Paste:=xlPasteValues

    Else  '業者名のシートがなかった場合
        '業者名のシートを挿入
        Worksheets.Add(after:=Sheets(Sheets.Count)).Name = Rng.Value
        '業者名毎のデータの抽出
        WS1.Range("B7").AutoFilter Field:=2, Criteria1:=Rng.Value
        '抽出したデータに対応する業者名のシートにデータをコピー
        WS1.Range("D8:K" & LastRow1).Copy
        Sheets(Rng.Value).Range("B8").PasteSpecial Paste:=xlPasteValues

    End If

        WS1.Range("B8").AutoFilter  'オートフィルタの解除

 Next Rng
 Application.DisplayAlerts = False  '警告メッセージの表示を無効
 WS2.Range("A:A").Clear  '作業用シートのデータ削除
 Application.DisplayAlerts = True  '警告メッセージの表示を有効
 WS1.Activate
 Application.ScreenUpdating = True '画面の更新を有効

 End Sub

 Autofilter実行時には実際にどの列からオートフィルタの範囲となっているか。
B列からならField:=1でないと理屈に合わない。A列からのオートフィルタ範囲
ならば別にこの点は問題なし。
　
業者シート名がない場合には転記場所としてB8が指定してあります。
これに対し、
業者シート名がある場合にはLastRow3を求めて、それを基準に転記
していますよね。
上記が実際の運用状況に適合しているかどうかではないでしょうか。
貼り付け時点のB列のデータ状況により貼り付け位置が変化します。
ですが、
＞A社への注文内容も転記されてしまいます。
この現象は確認できませんでした。
原因は何であるにせよ、
 Application.ScreenUpdating = False '画面の更新を停止
これをコメントアウトした上で、ステップインデバッグを行い、
ご自身でどの部分が希望通りの動作をしていないのか追跡してみる
必要があります。
(みやほりん)(-_∂)b

 みやほりんさん、体調を崩してしまい､御返事遅くなってスミマセン。
 ご教示いただきましたこと､試して見ました。何が良かったのか判らなかったのですが､正常に動作するように
なりました。本当にお世話になりました。

コメント返信：

[ 一覧(最新更新順) ]

[[20080716113841]] 『またまた分からなくなってしまいました。助けて～』（nori） ページの最後に飛ぶ

[[20080716113841]]　『またまた分からなくなってしまいました。助けて～』（nori）　ページの最後に飛ぶ