事務関係で営業成績をまとめるVBAを作成しています。

質問

事務関係で営業成績をまとめるVBAを作成しています。
２点程困っている部分があり質問させて頂きます。

内容としては、５つの部署が同フォーマットのエクセルファイルで営業の報告してきます。
そのエクセルファイルには「営業一覧」というシートがあり、
B列に「新規獲得」とあるもののみオートフィルタで抽出し、
C列の「会社名」のみを別ファイルのSheet2にまとめたいと思っています。

以下プログラムの一部になります。

※filelist = 各部署のエクセルファイル

For i = 0 To 5
Workbooks.Open folderspec & "￥" & file_list(i).ReadOnly
Workbooks(file_list(i)).Worksheets("営業一覧").Active

With Workbooks(file_list(i)).Worksheets("営業一覧").Range("A1")
.AutoFilter Field = 2, Criterial = "新規獲得"

Range("C2").Select
Range(Selection, Selection.End(xlLastCell)).Select

Selection.Copy main_workbok.Worksheets("Sheet2").Cells(cnt_cpy, 1)

.AutoFilter
End With

cnt_cpy = cnt_cpy + 1
Workbooks(file_lst(i)).Close SaveChanges:=False
Next i

(1)現在以下で1004エラーが発生し、別シートに貼り付けで出来ないといわれています。
Selection.Copy main_workbok.Worksheets("Sheet2").Cells(cnt_cpy, 1)
おそらくですが、コピーする領域がひろすぎて65535？を超過してしまっているのでは
ないかと思います。
この場合抽出領域だけを選択し、コピーするにはどうしたらよいでしょうか。
また、フィルタ結果が一件も無い場合はどうしたらよいでしょうか。

(2)このプログラムでは、１つ目の部署に新規獲得会社が２件、また２つ目の部署に新規獲得会社が２件
存在していた場合、cnt_cpyがうまく件数をカウント出来ず、
４件ではなく３件が表示されてしまいます。(つまり１つ目の部署の２件目がきえてしまう。)
この様な内容を解消するにはcnt_cpyをどのように扱えばよいでしょうか？

わかりずらい記述もありますが、困っておりますので、
なにか情報を頂けましたら幸いです。よろしくお願いいたします。

回答No.2

hige_082 · ベストアンサー

＃１です、補足読みました
その通りです

一つ目は、抽出データがある場合と無い場合の分岐です
その判断のために、最終行を求め判断しています

二つ目は
抽出されたデータ範囲
.Range("C2", .Cells(Rows.Count, 3).End(xlUp)).Select
可視セルの選択
Selection.SpecialCells(xlCellTypeVisible)
選択範囲のコピー
Selection.Copy
これをまとめたものです

三つ目は、んっ・・・？
二つ目の・・・.Copyの後、半角スペースに続けて入力したつもりだったのですが改行されてますね・・・すみません
二つ目と三つ目で一つの命令です。
.Range("C2", .Cells(Rows.Count, 3).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy
main_workbok.Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset (1)
の2行を
.Range("C2", .Cells(Rows.Count, 3).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy _
main_workbok.Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset (1)
へ置き換えてください
改めて、三つ目はコピー先シートのA列最終行の一つ下の行へ貼り付け
この様にすることによって、確実に貼り付け場所の指定ができる

うまく処理されなかったから補足されたのですね
すみません、私のミスです
ご迷惑掛けました

お礼

返答が遅くなり申し訳ありませんでした。
無事完成させることが出来ました。

適切なアドバイス＆プログラム、有難う御座いました。

回答No.1

hige_082

まずは、添削から
＞Workbooks.Open folderspec & "￥" & file_list(i).ReadOnly
これは、読取専用で開こうとしているのですか？
だとすれば、間違いです
＞.AutoFilter Field = 2, Criterial = "新規獲得"
ここで、エラーが出てると思うのですが
引数の構文が間違っています
＞Range(Selection, Selection.End(xlLastCell)).Select
Endプロパティに定数xlLastCellは使用できません
構文など基本的なところをヘルプ等で理解を深めてはと思います

'上記の訂正もしてあります
Dim RWbook As Workbook
For i = 0 To 5
Set RWbook = Workbooks.Open(Filename:=folderspec & "￥" & file_list(i), ReadOnly:=True)
With RWbook.Worksheets("営業一覧")
.Range("A1").AutoFilter Field:=2, Criteria1:="新規獲得"
If .Cells(Rows.Count, 3).End(xlUp).Row <> 1 Then
.Range("C2", .Cells(Rows.Count, 3).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy
main_workbok.Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset (1)
.Cells.AutoFilter
End With
RWbook.Close SaveChanges:=False
Next i

質問の(1)(2)も解決していると思います
以上、参考まで

補足

早急な回答ありがとうございました。
VBAに詳しくないもので回答について再度ご質問よろしいでしょうか。
もしみられておりましたら、ご回答頂ければと思います。よろしくお願い致します。

＞If .Cells(Rows.Count, 3).End(xlUp).Row <> 1 Then
これはC列に入力されている最終セルを確認し、入力されていれば～、ということですよね。

＞.Range("C2", .Cells(Rows.Count, 3).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy
これはC列に入力されているセル、更には見出し等以外の可視セルをコピーする、ということですよね。

＞main_workbok.Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset (1)
これはちょと自信がないのですが、
シート２の入力されている最終セルを確認し、その一つ下の行に貼り付けをする、ということでしょうか。