VBAであるシートに入力した内容を別のシートの表にコピーして一覧を作成したい

前提・実現したいこと

当方VBA初心者です。
イメージとしては、発注書のようなものの履歴を表にして残したいです。

Aのシートに入力し、ボタンを押すとその内容が別シートの表にコピーされる。
入力するシートは、都度使用され、表シートには最終行から随時追加されるかたちにしたいと考えてます。

入力シートのA2:D2とA5:D8に入力する欄があり、A2:D2を表シートのA:Dに、A5:D8を表シートのE:Hに
ボタンを押すと貼り付けられるようにしたいです。

2回目以降に表に追加する時、空白のセルがあると最終行になって上書きされてしまうので
空白のセルには上の行をコピーして埋めたいと考えました。

該当のソースコード

途中までしかありませんが…
空白のセルを埋める部分を調べてみましたが、どうにもうまくいきませんでした。

Sub rireki()

    '発注書の内容をコピー
    Sheets("入力").Range("A2:D2").Copy
    Sheets("履歴表").Select
    
    '最終行の1個下のセルを取得
    Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
    
    '発注書の内容を値のみペースト
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

　　'発注書の内容をコピー
    Sheets("入力").Range("A5:D8").Copy
    Sheets("履歴表").Select
    
    '最終行の1個下のセルを取得
    Cells(Rows.Count, 5).End(xlUp).Offset(1, 0).Select
    
    '発注書の内容を値のみペースト
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

補足情報

入力シートの形は、変えれないですが、表は後から見てソートしやすいのがベターですが、とりあえず表ができるだけでも助かります。
Excel2016です。
拙い文章で申し訳ありません。
足りない情報などございましたらご教示いただけると幸いです。

radames1000

2020/08/18 07:06

まずご自身で作成されたコードを教えてください。

meg_

2020/08/18 08:37

やりたいことのイメージは分かりましたが、課題は何でしょうか？「当方VBA初心者です。」とありますが、どのくらいコードは書けるのでしょうか？

mutttttton

2020/08/18 08:38

早速のご回答ありがとうございます。申し訳ありませんでした。書いてる途中で投稿してしまいました。。更新して改めて投稿いたしました。

mutttttton

2020/08/18 08:48

>meg_さん更新しました。伝わりますでしょうか。。コードはほとんどネットで調べながら切り貼りしています。。

meg_

2020/08/18 08:52

・上記コードは動作しますか？・「どうにもうまくいきませんでした」とありますが具体的に何がどう駄目だったのでしょうか？画像は「画像の挿入」で貼れませんか？やはりシートのイメージ画像があった方が検証しやすいです。

mutttttton

2020/08/18 09:34

もう一度更新しなおしたら画像は貼れました。コードは動作します。エラーは特にありません。・「どうにもうまくいきませんでした」　⇒調べてみたのですが、私がやりたいことがみつかりませんでした。

行動規範の内容に同意します

回答2件

ベストアンサー

VBA
1Sub rireki()
2
3    Sheets("履歴表").Select
4
5    '貼り付け開始行を取得
6    Dim startRow As Long
7        startRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
8    
9    '貼り付け行数の取得
10    Dim psRow As Long
11        psRow = Sheets("入力").Range("a4").CurrentRegion.Rows.Count - 1
12        
13    '最終行の取得
14    Dim maxRow As Long
15        maxRow = startRow + psRow - 1
16        
17    '発注書の内容をコピー
18    Sheets("入力").Range("A2:D2").Copy
19    Range(Cells(startRow, 1), Cells(maxRow, 1)).PasteSpecial Paste:=xlPasteValues
20
21    Sheets("入力").Range("A5:D8").Copy
22    Cells(startRow, 5).PasteSpecial xlPasteValues
23    
24    'メーカーの空欄をうめる
25    With Range(Cells(startRow, 5), Cells(maxRow, 5))
26        .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
27        .Value = .Value
28    End With
29    
30    '貼り付け開始行を選択する※無くても問題ないです
31    Cells(startRow, 1).Select
32    
33End Sub

こんな感じでしょうか。

VBA
1Sub rireki2()
2
3    Sheets("履歴表").Select
4
5    '貼り付け開始行を取得
6    Dim startRow As Long
7        startRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
8
9    '発注書の内容をコピー
10    Sheets("入力").Range("A5:D8").Copy
11    Cells(startRow, 5).PasteSpecial xlPasteValues
12
13    '最終行の取得
14    Dim maxRow As Long, cntRow As Long
15        maxRow = Cells(Rows.Count, 6).End(xlUp).Row + 1
16        Do Until cntRow > 0
17           maxRow = maxRow - 1
18           cntRow = WorksheetFunction.Count(Range(Cells(maxRow, 1), Cells(maxRow, 8)))
19        Loop
20    
21    '貼り付け行数の取得
22    Dim psRow As Long
23        psRow = maxRow - startRow + 1
24        
25    '発注書の内容をコピー
26    Sheets("入力").Range("A2:D2").Copy
27    Range(Cells(startRow, 1), Cells(maxRow, 1)).PasteSpecial Paste:=xlPasteValues
28
29    'メーカーの空欄をうめる
30    Dim rng As Range
31    For Each rng In Range(Cells(startRow, 5), Cells(maxRow, 5))
32        If rng.Value = "" Then
33            rng.Value = rng.Offset(-1).Value
34        End If
35    Next
36
37    '貼り付け開始行を選択する※無くても問題ないです
38    Cells(startRow, 1).Select
39
40End Sub

投稿2020/08/19 00:47

編集2020/08/20 07:12

radames1000

総合スコア1923

mutttttton

2020/08/20 05:45

ご回答ありがとうございます！概ね希望のことができました。こちらの情報の共有不足で申し訳ないのですが A5:D8は、他のシートからデータを引っ張りたいので空欄ではなくIF関数などで空白にするとその行まで履歴表にコピーされてしまうのですが、これの回避方法はありませんでしょうか。

mutttttton

2020/08/20 08:48

重ねてありがとうございます。思った通りのものができました。

行動規範の内容に同意します

VBA
1Sub rireki()
2
3    '発注書の内容をコピー
4    Sheets("入力").Range("A2:D2").Copy
5    Sheets("履歴表").Select
6
7    '最終行の1個下のセルを取得
8    Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
9    
10    Dim start As Integer '#### 追加
11    start = Cells(Rows.Count, 1).End(xlUp).Row + 1 '#### 追加
12
13    '発注書の内容を値のみペースト
14    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
15
16    '発注書の内容をコピー
17    Sheets("入力").Range("A5:D8").Copy
18    Sheets("履歴表").Select
19
20    '最終行の1個下のセルを取得
21    Cells(Rows.Count, 5).End(xlUp).Offset(1, 0).Select
22
23    '発注書の内容を値のみペースト
24    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
25    
26    '#### 追加ここから
27    Dim i As Integer
28    
29    For i = Cells(Rows.Count, 6).End(xlUp).Row To Cells(Rows.Count, 1).End(xlUp).Row + 1 Step -1
30        Range(Cells(i, 1), Cells(i, 4)).Value = Range(Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 4)).Value
31    Next i
32    For i = start To Cells(Rows.Count, 6).End(xlUp).Row
33        If Cells(i, 5).Value = "" Then
34            Cells(i, 5).Value = Cells(i - 1, 5).Value
35        End If
36    Next i
37    '#### 追加ここまで
38
39End Sub
40