エクセルvbaでのセルの情報を貼り付け方法

質問

vba初心者です。sheet1にあるセルの情報をsheet2にあるセルに貼り付けようと考えています。
下記のようにプログラムしました。

If Cells(Line, 6).Value = "" Then

Cells(Line, 6).Value = "データがありません"

Cells(Line, 5).Value

GoTo コピー貼り付け

End If

コピー貼り付け:

Cells(Line, 5).Copy 'コピーする
Worksheets("輸入Parts").Range("A2").PasteSpecial Paste:=xlPasteValues
'値を貼り付け

問題はコーピー貼り付けの箇所でRange("A2")ではなくA列の最初の空白のセルに貼り付けるようにしたいです。
どなたかお力をお貸しください。

回答No.4

satoron666

補足いただいたので、内容を確認。

ただ、気になるのが
質問には
>sheet1にあるセルの情報をsheet2にあるセルに貼り付けようと考えています。
と書いてあります。　その記述はどこへ？

ところで、このVlookup、上手くいってるんですか？
試したらエラーが出たので他の方法を使っていますが。

-------------------------------------
Sub TEST()
Dim line As Long
Dim i As Long
Dim maxrow As Long

line = 1

With ThisWorkbook.Worksheets("Sheet1")

For line = 1 To .Cells(Rows.Count, 5).End(xlUp).Row
If Application.WorksheetFunction.IsError(Application.VLookup(.Cells(line, 5).Value, Worksheets("Sheet2").Range("A1:R20000"), 2, 0)) = True Then
.Cells(line, 6).Value = "データがありません"
maxrow = Worksheets("Sheet2").Range("A1").End(xlDown).Row + 1
Worksheets("Sheet2").Range("A" & maxrow) = .Cells(line, 5)
Else
.Cells(line, 6).Value = Application.VLookup(.Cells(line, 5).Value, Worksheets("Sheet2").Range("A1:R20000"), 2, 0)
End If
Next
End With
End Sub

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

とりあえず、こういうことでしょうか。
Vlookupの場合、普通にやるとエラーが出るため
WorksheetFunctionを省くと良いそうです。

Application.WorksheetFunction.IsErrorというのは、エラーかどうかを判別しています。
エラーの場合は結果がTrueになるので、
Trueかどうかで判定してやることを分けています。

1行1行、どのような流れか理解したほうが良いですよ。
修正が大変ですから。

お礼

ご指導ありがとうございました。もう少し勉強します。

回答No.3

satoron666

どれがなんで、どうしたいのか
さっぱり意味が分からなくなってきました。

適当でいいので、サンプルデータと、途中までのプログラムを見せてください。
そしたら普通にできますので。

補足

下記のような感じでプログラムしています。よろしくお願いします。

If Cells(Line, 5).Value = "" Then

Cells(Line, 5).Value = Cells(Line - 1, 5).Value

End If

Cells(Line, 6).Value = Application.WorksheetFunction.VLookup(Cells(Line, 5).Value, Worksheets("輸入Parts").Range("A2:R20000"), 2, 0)

'E列を検索しデータが存在しない場合はF列に「データがありません」を表記

If Cells(Line, 6).Value = "" Then

Cells(Line, 6).Value = "データがありません"

GoTo コピー貼り付け

End If

コピー貼り付け:

If Cells(Line, 6).Value = "データがありません" Then

Cells(Line, 5).Copy 'コピーする

Maxrow = Worksheets("輸入Parts").Range("A1").End(xlDown).Row + 1

Worksheets("輸入Parts").Range("A" & Maxrow).PasteSpecial Paste:=xlPasteValues '値を貼り付け

End If

回答No.2

satoron666

>Dim　MaxRow=CopyToSheet.Range("A1").End(xlDown).Row+1

>Dimの箇所は定義づけられてませんが間違いでしょうか？

MaxRowを関連付けるの忘れてました（苦笑
　Dim　MaxRow　as　long
という一文を最初のほうに追加すれば大丈夫かと。

あと、
>Set CopyToSheet = Wb.Worksheets("輸入Parts")
>Set CopyFromSheet = Wb.Worksheets("Sheet1")

エラーになって当然ですしたね…
Wbなんて定義してないですし。

Set CopyToSheet = Thisworkbook.Worksheets("輸入Parts")
Set CopyFromSheet = Thisworkbook.Worksheets("Sheet1")

これだと上手くいくかなぁ…

補足

輸入PartsシートのA2が空欄だと張り付きません。どうすればいいでしょうか？

回答No.1

satoron666

http://www.moug.net/tech/exvba/0150065.html
http://www.niji.or.jp/home/toru/notes/8.html

MaxRow = Range("A1").End(xlDown).Row+1
これで、A列の空白行にいけると思います。

また、コピーなどではなく、
＝でつなぐのはどうでしょう？

Set CopyToSheet = Wb.Worksheets("輸入Parts")
Set CopyFromSheet = Wb.Worksheets("Sheet1")

Dim　MaxRow=CopyToSheet.Range("A1").End(xlDown).Row+1

If CopyFromSheet.Cells(Line, 6).Value = "" Then

CopyFromSheet.Cells(Line, 6).Value = "データがありません"

CopyToSheet.Range("A" &　MaxRow)=CopyFromSheet.Cells(Line, 5).Value

End If

とかでしょうか？
上手く行くかは自信ないですが…

補足

早速のご連絡ありがとうございます。
試しましたが下記の箇所でエラーが出てしましました。

Set CopyToSheet = Wb.Worksheets("輸入Parts")
Set CopyFromSheet = Wb.Worksheets("Sheet1")

Dim　MaxRow=CopyToSheet.Range("A1").End(xlDown).Row+1

Dimの箇所は定義づけられてませんが間違いでしょうか？