VBA空白(数式での””を含む）を除いてコピーが出来ません。ご指導お願い致します。

下記のVBA記述で実行した場合空白セル(数式での解""を含む）も集約ファイルにコピーされてしまう状況です。
空白セルを除く場合の修正点をご教示お願い致します。

実施内容としては、シート名に案件とついたシートを、allというシートにコピーしております。
その際に下記記述では空白セルもコピーされてしまう為、除いた状態で集約したいという内容です。

Sub Sample()
Dim dWS As Worksheet

Set dWS = Worksheets("all")


dWS.UsedRange.Offset(1, 0).Clear

Dim w
Dim Last_data
For Each w In Worksheets

If InStr(w.Name, "案件") > 0 Then

w.Range("a18", "J79").Copy

Last_data = Worksheets("all").Range("a" & Rows.Count).End(xlUp).Row

Worksheets("all").Range("a" & Last_data + 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=True, Transpose:=False

End If

Next


End Sub

質問者からの補足コメント

• tatsu99　様
  
  ご相談に応じて下さりありがとうございます。
  
  添付画像の様に行に入力があり、列が空白という状況は起こりにくいかとは思いますが、
  行が空欄の場合は詰めて格納し、列は詰めずにという格納方法を実施したいです。
  
  現在は店舗名欄に入力があればデータを引っ張ってきて格納するという形で対応したいと考えており、
  添付画像のA案件の数式の様な形で店舗名を入力するか、入力しないかを決めている状況です。
  
  各シート毎にA１には店舗名を入力済み
  =IF(E3<>"",$A$1,"")
  
  拙い文章で御迷惑をお掛け致しますが、よろしくお願い致します。

  
  No.1の回答に寄せられた補足コメントです。 補足日時：2016/11/30 14:46

• 添付画像

  
    補足日時：2016/11/30 14:47

• 添付画像

  
    補足日時：2016/11/30 14:48

• tatsu99 様
  
  大変丁寧なご回答ありがとうございます。
  重ねてのご質問で大変申し訳ないのですが、各シートの19行目以降をコピー対象とする場合、どの部分を修正させて頂けばよろしいでしょうか。
  
  お手数をお掛け致しますが、よろしくお願い致します。

  No.3の回答に寄せられた補足コメントです。 補足日時：2016/12/01 16:04

No.4 回答者： tatsu99 回答日時： 2016/12/01 18:29

No3です。

>重ねてのご質問で大変申し訳ないのですが、各シートの19行目以降をコピー対象とする場合、どの部分を修正させて頂けばよろしいでしょうか。

19行目以降をコピーするようにしました。
合わせて、以下の修正を行いました。
１）シート：all以外を表示した状態で実行すると正しく動作しない不具合を修正。（どのシートを表示した状態でもマクロを実行可能にしました）
２）終了時にメッセージを表示するようにしました。
以下のマクロを登録してください。（前回のは全て破棄してください）
------------------------------------------------------------
Option Explicit
Public Sub all転記()
Dim sh1 As Worksheet 'all用
Dim Maxrow As Long 'allの最大行
Dim startrow As Long 'allの編集開始行
Dim wk As Worksheet '作業用シート
Set sh1 = Worksheets("all")
Maxrow = sh1.Cells(Rows.Count, 1).End(xlUp).Row ' 最終行を求める
If Maxrow > 1 Then
'2行目以降を削除
sh1.Range("A2:A" & Maxrow).EntireRow.Delete
End If
startrow = 2
'シート全体について繰り返し
For Each wk In Worksheets
'シート名が"案件"を含むなら
If InStr(wk.Name, "案件") > 0 Then
'該当シートをallへ転記
Call tenki(sh1, wk, startrow)
End If
Next
MsgBox ("処理完了")
End Sub
'1シート分をallへ転記
Private Sub tenki(ByVal sh1 As Worksheet, ByVal sh As Worksheet, ByRef startrow As Long)
Dim wrow As Long
Dim Maxrow As Long
Maxrow = sh.Cells(Rows.Count, 1).End(xlUp).Row ' 最終行を求める
For wrow = 19 To Maxrow
'空白行でないならその行をコピー
If sh.Cells(wrow, 1).Value <> "" Then
sh1.Range(sh1.Cells(startrow, 1), sh1.Cells(startrow, 10)).Value = sh.Range(sh.Cells(wrow, 1), sh.Cells(wrow, 10)).Value
startrow = startrow + 1

End If
Next
End Sub
---------------------------------------------------
尚、19行目以降をコピーしていますが、それを修正したい場合は
Private Sub tenki(ByVal sh1 As Worksheet, ByVal sh As Worksheet, ByRef startrow As Long)
の中の
For wrow = 19 To Maxrow
を
For wrow = xx To Maxrow
に変えてください。（xxはコピーを開始したい行です。）

No.3 回答者： tatsu99 回答日時： 2016/11/30 17:57

以下のマクロを標準モジュールへ登録し実行してください。

--------------------------------------------
Option Explicit
Public Sub all転記()
Dim sh1 As Worksheet 'all用
Dim Maxrow As Long 'allの最大行
Dim startrow As Long 'allの編集開始行
Dim wk As Worksheet '作業用シート
Set sh1 = Worksheets("all")
Maxrow = sh1.Cells(Rows.Count, 1).End(xlUp).Row ' 最終行を求める
If Maxrow > 1 Then
'2行目以降を削除
Range("A2", Cells(Maxrow, 1)).EntireRow.Delete
End If
startrow = 2
'シート全体について繰り返し
For Each wk In Worksheets
'シート名が"案件"を含むなら
If InStr(wk.Name, "案件") > 0 Then
'該当シートをallへ転記
Call tenki(sh1, wk, startrow)
End If
Next
End Sub
'1シート分をallへ転記
Private Sub tenki(ByVal sh1 As Worksheet, ByVal sh As Worksheet, ByRef startrow As Long)
Dim wrow As Long
Dim Maxrow As Long
Maxrow = sh.Cells(Rows.Count, 1).End(xlUp).Row ' 最終行を求める
For wrow = 3 To Maxrow
'空白行でないならその行をコピー
If sh.Cells(wrow, 1).Value <> "" Then
sh1.Range(sh1.Cells(startrow, 1), sh1.Cells(startrow, 10)).Value = sh.Range(sh.Cells(wrow, 1), sh.Cells(wrow, 10)).Value
startrow = startrow + 1

End If
Next
End Sub
------------------------------------------------
作成時の条件として
１）各案件のシートが空白行か否かはA列の該当行が空白かどうかで判断しています。
（他の列にデータがあってもA列が空白なら空白行として扱います）
２）allへコピーする場合、サンプルソースではA列～J列までコピーしていましたので、A列～J列をコピーしています。

マクロを実行した結果、上記の条件で不都合がある場合は、その旨補足してください。

No.2 回答者： fujillin 回答日時： 2016/11/30 17:51

こんにちは

よくわからないところがあるので、考え方のみですが・・・

『各シートの18行目から79行目のうち空白ではない行をコピーしたい。』ということだと解釈しました。
推測ですが、空白かどうかはA列の値が""か否かで判断しても良さそうに思いました。
（コピー先のLast_dataの判定をA列で行っているようですので…）

方法として考えられるのは、
1）ご提示の方法で一旦全てコピーしてから、集計シート（all)の空白行を削除してしまう。
この方法なら、単純に、『最終行まででA列が空白の行を削除する』という処理をご提示のコードに付け加えるだけで可能と思います。
（削除の場合は、上から処理せずに下から順に処理するのがコツです）

2）コピーする際に「a18;J79」のような固定の範囲でコピーせずに、ループで一行ずつコピーするようにし、その際にA列の値が""の行はスキップする。
この方法の場合は、ご提示のコードのコピーをしている部分を、1行ずつループで処理するように修正すればできそうですね。
範囲でコピーする場合に比べて、若干時間がかかる可能性がありますが、ものすごく大量でなければ気にならない範囲と思います。


・・・と書きながら、なんとなくコピー元のシートのデータは行が飛び飛びに入力されているわけではなく、順に詰められているのだけれど「a18;J79」でコピーしているので下の方の空白行の分がそのままコピーされて、見た目に空白ができてしまっているのではないかという気がしてきました。

もしそうであるなら、Last_dataを求める際に空白文字列の行を詰めて判定することでも良さそうです。
簡単にできないかと少し調べてみましたが、結局、地道にやるしかなさそうでした。
（エクセルのEndメソッドはEmptyセルか否かで判断しているようで、空白文字列（""）のセルはEmptyとは判断されないようですね）

Dim lastC As Range

Set lastC = dWS.Range("A" & Rows.Count).End(xlUp)
While lastC.Row > 1 And lastC.Offset(-1) = ""
　Set lastC = lastC.Offset(-1)
Wend

などとすることで、lastCにA列の実質の最下行の次のセルを求めることができますので、次のペーストをこのセルから始めれば良いのではないでしょうか。

上例はコピー先のシートでの処理を想定していますが、「コピー元のシートで同様のことを行ってコピーする範囲を決める」という方法のほうが実際には良さそうですね。
その際には、コピー先のシートでは上記の判定を行う必要はなくなるものと思います。


※ ついでながら、ご提示のコードで
　Set dWS = Worksheets("all")
のようにせっかくシートを変数に代入しているので、あとのコードでそれを利用しない手はないと思います。
同じ文字の繰り返しが無くなり、コードも短くなるので認識しやすくなるのと、実行速度もごくわずかですが速くなるはずです。（感じられない程度と思いますが…）

この回答へのお礼

fujillin　様
私の拙い文章から推測して頂いた上に、ご丁寧な回答、アドバイスありがとうございます。
今後VBAを組み立てる際には変数代入をしっかり意識したいと思います。

お礼日時：2016/12/01 16:06

No.1 回答者： tatsu99 回答日時： 2016/11/30 13:23

＞実施内容としては、シート名に案件とついたシートを、allというシートにコピーしております。

＞その際に下記記述では空白セルもコピーされてしまう為、除いた状態で集約したいという内容です。

空白セルを除いてコピーすると、集約シートには、詰めて格納するのですか？
例えば、案件１のシートの１８行の
A18がX、J18がYとし、B18～I18は全て空白とします。
コピー対象となるのは、A18、J18ですが、これを集約シートにどのように格納するのですか。
集約シートのA2へX・・・これはOK
集約シートのB2へY・・・このように詰めて格納ですか？

又、案件１のシートの１９行全体が空白の場合、その行はコピーしないので、
集約シートの3行目は、案件１のシートの20行目をコピーするということでしょうか。

つまり、空白セルがある場合、列を詰めて格納し、空白行がある場合、行を詰めて格納するということでしょうか。

空白セルがある場合、具体的にどのように格納したいのかを提示していただければ、対応は可能ですが、
現状ではあなたの望む結果が判りませんので対応は難しいかと・・・。