VBA空白を除いてコピーが出来ません。ご指導お願いします。

値のコピー＆ペースト（空白を除いてコピー）したいと思っております。

シート１　の　A35、D35、I35　をコピー。
シート２　の　A2　に貼り付け。

これは、大丈夫です。

シート１　の　M2　：　O23　をコピー。
シート２　の　E2　に貼り付け。

今回の場合ですと、M2　：　O13　までに値が入ってます。
ですので、M14　：　O23　までが、空白になって記入となってしまいます。
＊毎回、値が入る量が違います。

一回のコピーですと、これでもいいのですが、
値を変更して、コピーを続けてしますので、M14　：　O23　までが、空白になってM24からのコピーになってしまいます。

空白を除いて、貼り付けしたいのですが、
どうすればいいのかわかりません。
お分かりになる方、ご指導よろしくお願いします。

VBAは以下になっております。
Sub Macro1()
'
Application.ScreenUpdating = False

Sheets("Sheet1").Range("A35,D35,I35").Copy

If Sheets("Sheet2").Range("A2").Value = "" Then
Sheets("Sheet2").Range("A2").PasteSpecial Paste:=xlPasteValues
Else

Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
End If


Sheets("Sheet1").Range("M2:O23").Copy

If Sheets("Sheet2").Range("E2").Value = "" Then

Sheets("Sheet2").Range("E2").PasteSpecial Paste:=xlPasteValues
Else

Sheets("Sheet2").Range("E" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

End If

Application.CutCopyMode = False

Application.ScreenUpdating = True
End Sub

よろしくお願いします。

No.6 ベストアンサー 回答者： myRange 回答日時： 2009/12/03 11:59

回答２、myRangeです。

いま補足を見ましたので、回答します。
　
回答２、補足のコード、
＞For Each Rng In Sheets("Data").Range("FP63367:FR63388")
は、ＦＰ63367:ＦＲ63388　が間違いです。

回答２のその部分をよーく見ればわかると思いますが、
Ｍ２：Ｏ２３　ではなくてＭ列のみ指定（Ｍ２：Ｍ２３）してありますよね。

なので、ＦＰ～ＦＲ列なら、
最初の列、ＦＰ列のみを指定しないといけません。

　　ＦＰ63367:ＦＰ63388
　
-------------------------------------------------------

Sub Macro1編集後()
Application.ScreenUpdating = False
Dim Rng As Range
Dim LastRow As Long

●ここをＦＰ63367:ＦＰ63388とＦＰ列だけ指定する

For Each Rng In Sheets("Data").Range("FP63367:FP63388")


If Rng.Value <> "" Then
LastRow = Sheets("拾い出し").Cells(Rows.Count, "P").End(xlUp).Row
Sheets("拾い出し").Cells(LastRow + 1, "P").Resize(1, 3).Value = Rng.Resize(1, 3).Value
End If
Next Rng
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub
-----------------------------------------------------

以上です。

この回答へのお礼

myRangeさん、回答ありがとうございます。

私のやりたい事、すべて出来ました～

めっちゃうれしいです。

何度も回答して頂きありがとうございました。
今後共、よろしくお願いします。

お礼日時：2009/12/03 12:37

No.5 回答者： noname#99913 回答日時： 2009/12/03 11:17

kozirou54です。

「Option Explicit」は、すべてのコードの最初になければいけません。つまり、

Option Explicit
Sub Macro1()
・・・・・・
End Sub

の順番に記述しなければいけません。

実は「Option Explicit」はなくても動きます。邪魔なようでしたら、削除してください。

この回答へのお礼

kozirou54さん、回答何度もありがとうございます。

できました～！

ひとつの事、するのだけでも、色々なやり方があるのですね～

何度もすみませんでした。

今後共、よろしくお願いします。

お礼日時：2009/12/03 11:47

No.4 回答者： noname#99913 回答日時： 2009/12/03 10:07

すみません、間違えました。

5行目を、

For r = 2 To 23

に変えてください。

この回答へのお礼

kozirou54さん、何度も回答ありがとうございます。

新しいファイルを作り、同じように
シート１のM2：O23に表を作りました。
kozirou54さんの、教えて頂いたVBAを書き込みましたが、
同じようにエラーがでます。
どこが、いけないのかわかりません。

以下が私の書き込みしたVBAです。
Sub Macro1()

Option Explicit
Sub ValueCopy()

Dim r As Integer
Dim c As Integer
For r = 2 To 23
For c = 13 To 15

If Sheets(1).Cells(r, c).Value <> "" Then
Sheets(2).Cells(r, c - 8).Value = Sheets(1).Cells(r, c).Value
End If

Next c
Next r
End Sub
お時間許すのであれば、ご指導よろしくお願いします。

お礼日時：2009/12/03 10:53

No.3 回答者： noname#99913 回答日時： 2009/12/03 10:01

あまり自信はありませんが、次のコードを試してください。

Option Explicit

Sub ValueCopy()

Dim r As Integer
Dim c As Integer

For r = 2 To 13
For c = 13 To 15

If Sheets(1).Cells(r, c).Value <> "" Then

Sheets(2).Cells(r, c - 8).Value = Sheets(1).Cells(r, c).Value

End If

Next c
Next r

End Sub

この回答へのお礼

kozirou54さん、回答ありがとうございます。
早速、試して頂きました。
ですが、エラーが出ます。

コンパイルエラー：
プロシージャ内では無効です。
Option Explicitが選ばれております。

私は、VBAは詳しくなく、ここでみなさんに教えて頂いた内容も
さっぱり解らない為、こうしたらどうなるか等、
色々している内に、VBAやエクセル内がぐちゃぐちゃになっています。
それが原因だと思います。

回答して頂きありがとうございました。
今後共、よろしくお願いします。

お礼日時：2009/12/03 10:28

No.2 回答者： myRange 回答日時： 2009/12/02 11:58

「空白」は、未入力（Empty）のことではなくて

式の結果、例えば、""（長さ０の文字列）のことをいってるのではありませんか？
で、あれば、ひとつずつ処理しなければできません。
　
例えば、以下のように。
'---------------------------------------------------　
　Dim Rng As Range
　Dim LastRow As Long

　For Each Rng In Sheets("Sheet1").Range("M2:M23")
　　　If Rng.Value <> "" Then
　　　　　LastRow = Sheets("Sheet2").Cells(Rows.Count, "E").End(xlUp).Row
　　　　　Sheets("Sheet2").Cells(LastRow + 1, "E").Resize(1, 3).Value = Rng.Resize(1, 3).Value
　　　End If
　Next Rng
'-------------------------------------------------

以上です。
　

この回答への補足

myRangeさん、回答ありがとうございます。

私のやりたい事すべて、出来ました～！
感動しまくってます～
それで、他のファイルにも、活用しようと試みました・・・がうまくいきません。

（行った作業）
Data! FP63367 : FR63388 をコピー
拾い出し! P4 に貼り付け

（結果）
P4　●　　　　　　　　　Q4　WT5001　　　R4　120
P5　WT5001　　　　　Q5　120
P6　120
P7 トリプル　　　　　　Q7　WT3003W　　　R7　41
P8　WT3003W　　　　Q8　41
P9　41
・
・
と値が重複して書き込まれます。

教えて頂いた、VBAの意味がわかっておらず色々数字を変えて試みましたが、おかしくなる一方で一向に改善できません。

どこがおかしいか、教えていただけませんか？
何度も、申し訳ありませんが、ご指導よろしくお願いします。

（VBA）以下を書き込みました。

Sub Macro1編集後()
Application.ScreenUpdating = False
Dim Rng As Range
Dim LastRow As Long

For Each Rng In Sheets("Data").Range("FP63367:FR63388")
If Rng.Value <> "" Then
LastRow = Sheets("拾い出し").Cells(Rows.Count, "P").End(xlUp).Row
Sheets("拾い出し").Cells(LastRow + 1, "P").Resize(1, 3).Value = Rng.Resize(1, 3).Value
End If
Next Rng
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

よろしくお願いします。

補足日時：2009/12/02 20:33

この回答へのお礼

myRangeさん、回答ありがとうございます。

おかげで、うまく出来ました～！
感動してます～

補足の書き込みについて教えて頂けませんか。

今後共、よろしくお願いします。

お礼日時：2009/12/02 20:37

No.1 回答者： noname#99913 回答日時： 2009/12/02 10:23

オプションで空白セルを無視するようにせっていすればいいのでは。

空白セルを無視し、すべて貼り付け
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=True, Transpose:=False

空白セルを無視し、値のみ貼り付け
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=False

この回答へのお礼

kozirou54さん、回答ありがとうございます。

その方法で、やらせて頂きましたが、やはり空白が入ってしまい
駄目でした。

ありがとうございました。
今後共、よろしくお願いします。

お礼日時：2009/12/02 20:11