複数セルの値を転記したいが、セル一個分しか転記されない

Question

###前提・実現したいこと
画像のエクセルの内容を、別シートに転記してデータベースを作成しようとしています。

###発生している問題・エラーメッセージ
画像の黄色いセルの内容しか転記されず、解決できずにいます。

###該当のソースコード

Set pasteCell = pasteWs.Cells(pasteWs.Rows.Count, "D").End(xlUp).Offset(0, 0)

    Dim sagyokingakuCell As Excel.Range
    With copyWs
        Set sagyokingakuCell = _
                .Range( _
                    .Range("B37"), _
                    .Range("B37").End(xlToRight).End(xlDown) _
                )

    End With 'copyWs


    'sagyokingakuCell.Copy
    'pasteCell.PasteSpecial Paste:=xlPasteValues, _
    '                       Operation:=xlNone, _
    '                       SkipBlanks:=False, _
    '                       Transpose:=False
    pasteCell.Value() = sagyokingakuCell.Value()

質問後、試したソースコード①

  pasteCell.Value() = sagyokingakuCell.Value()

質問後、試したソースコード②

        Set sagyokingakuCell = _
                .Range( _
                    .Range("B37:M37"), _
                    .Range("B37:M37").End(xlDown) _
                )
 
    End With 'copyWs

    pasteCell.Value() = sagyokingakuCell.Value()
    

質問後、試したコード③

Dim sagyokingakuCell As Excel.Range
Set sagyokingakuCell = copyWs.Range(Cells(37, 2), Cells(37, "13")).Select.End(xlDown).Select

pasteCell.Value() = sagyokingakuCell.Value()

やはり黄色いセルしか選択できていないようで、解決できずにいます。どうぞよろしくお願いいたします。

Answer 1

Range("B37").End(xlToRight).SelectでB37から最終行の右端までのセルが取れますか

Comments

[退会済みユーザー]

早速のご返信ありがとうございます！

キーボードで検証してみたらよいのですね！
たしかに、I37までしか選択できませんでした。。

[King_of_Flies]

であれば、Range(Cells(37,2),Cells(37,"何列目のセルまでか入力して")).Selectで試してみてください。

[King_of_Flies]

.Selectの記述は選択範囲の確認ができたら取ってしまって構いません。

[King_of_Flies]

補足ですが
何列目のセルまでか入力して　→　M列まで取りたいのであれば13と入れてください。

[退会済みユーザー]

早速のご返信ありがとうございます！
下記に変更してみましたが、黄色くハイライトされてデバッグ画面になってしまいました。構文間違ってるでしょうか？？
Dim sagyokingakuCell As Excel.Range
Set sagyokingakuCell = copyWs.Range(Cells(37, 2), Cells(37, "13")).Select.End(xlDown).Select

pasteCell.Value() = sagyokingakuCell.Value()

[King_of_Flies]

Dim sagyoukingakuCell As Range
Set sagyoukingakuCell = Range(Cells(37,2),Cells(37,13))
pasteCell.Value() = sagyoukingakuCell

かな？
メッセージはなんと出ていますか？

[King_of_Flies]

Range(Cells(37,2),Cells(37,13)).End(xlDown)

[退会済みユーザー]

ありがとうございます！
いただいたコードを試してみましたら、
sagyoukingakuCellがハイライトされて、「コンパイルエラー：変数が定義されていません」とメッセージでました。

[退会済みユーザー]

Set pasteCell = pasteWs.Cells(pasteWs.Rows.Count, "D").End(xlUp).Offset(0, 0)

Dim sagyokingakuCell As Excel.Range
Set sagyokingakuCell = copyWs.Range(Cells(37, 2), Cells(37, 13)).Select

pasteCell.Value() = sagyoukingakuCell.Value()

と変更してみても、同じメッセージが出ます。

[King_of_Flies]

sagyoukingakuCellがDimで宣言した文字列と、Setで使用している文字列が等しいことを確認してください。

誤字かと思われます。

[King_of_Flies]

sagyoukingakuCell →　sagyokingakuCellですかねｗ

[退会済みユーザー]

早速のご検証ありがとうございます！
タイポみつかりました！
直したところ、まだタイポがあるのかもしれないのですが、
実行したら下記が今度はハイライトされ、
｢実行時エラー２４２：オブジェクトが必要です」
と出てしまいました。
Set sagyokingakuCell = copyWs.Range(Cells(37, 2), Cells(37, 13)).Select

[King_of_Flies]

.Selectがいらないのと、copyWs.がいらないと思います。
sagyoukingakuCellはRange型なので、Range()で指定したもの以外不要です

[King_of_Flies]

Dim S1 As Worksheet
Dim S2 As Worksheet
'シート１をS1にセット。S1.Cells(1,2)でシート1のA2を参照できます。
sheet1.Activate
Set S1 = ActiveSheet
'シート２をS2にセット。S2.Cells(1,2)でシート２のA2を参照できます。
sheet2.Activate
Set S2 = ActiveSheet

Dim sagyokingakuCell As Range
'シート１のB37~M37を選択し、その列の最終行までをsagyoukingakuCellに格納します。
Set sagyoukingakuCell = Range(S1.Cells(37,2),S1.Cells(37,13).End(xlDown))

'シート２のA１にsagyoukingakuCellの値を貼り付けます。
S2.Cells(1,1).Value = sagyoukingakuCell.Value

[King_of_Flies]

いろいろやり方があるのですごく単純な方法で結果だけできるようにすると、こうなります。
'Sheets1にはコピー元のデータがあるシート名を入れてね
Sheets("Sheet1").Select
Range("B37", Range("M37").End(xlDown)).Select
Selection.Copy
'Sheet2にはコピーしたい先のシート名を入れてね
Sheets("Sheet2").Select
Range("B2").Select
ActiveSheet.Paste

[King_of_Flies]

上の処理は動作確認済みなのでやってみてください。

[退会済みユーザー]

わかりやすく、たくさんのアドバイス賜り、大変ありがとうございます！
いろいろなアプローチの仕方があるのですね！！
下記で、うまく実行することができたのですが、
コメントいただいた方法も試してみます！！

Dim sagyokingakuCell As Excel.Range

With copyWs
Set sagyokingakuCell = _
.Range( _
.Range("B37"), _
.Cells(.Rows.Count, "M").End(xlUp) _
)
End With 'copyWs

With pasteWs
Set pasteCell = .Cells(.Rows.Count, "D").End(xlUp).Offset(1, 0) _
.Resize(sagyokingakuCell.Rows.Count, sagyokingakuCell.Columns.Count)
End With 'pasteWS
pasteCell.Value = sagyokingakuCell.Value