マクロの転記について教えてください

Question

マクロを使って、ボタン一つで別ブックの表に転記を行いたいです。

下記添付画像は簡易的な表ですが、
「転記元シート」から別ブックの「転記先シート」へ、同じ色の部分のデータを転記したいと考えています。

元々下記コードを使って、一行丸々コピーして貼り付けをしていたのですが、
転記先シートの仕様上、丸々コピぺではなく、部分的にコピペして貼り付けたいです。

Range(Cells(), Cells()).Copy
  
  Workbooks.Open FileName:= _
     ”転記先ブックのパス”
     
  Dim Lastrow As Long
  With ActiveSheet
    Lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
    .Cells(Lastrow + 1, 1).Select
  
  ActiveCell.PasteSpecial Paste:=xlPasteValues
  
  
  ActiveWorkbook.Save

  
  End With

動作の流れとしては、
①転記元シートにある「転記ボタン」を押す
②各色と同じセルの内容がコピーされて、転記先シートに転記される
③転記先シートには自動で上の行から順番に転記されていく
このような流れをイメージしています。

できれば上記コードを少しいじる程度で解決できるのであればそうしていただけると助かります。

VBAは初心者で、上記コードもネットに載っていたものを使っている形です。

拙い説明で申し訳ございませんが、宜しくお願い致します。

Qchan1962 · Accepted Answer

.Cells(Lastrow + 1, 1).Select
ActiveCell.PasteSpecial Paste:=xlPasteValues
同じ列を選択してペーストしているからです。
.Cells(Lastrow + 1, ？).Select
？部分を直しましょう

Qchan1962 · Answer

#1です
要は転記元シートの行番号を取得するコードですね。
＃１はミスがありますので、下記を参考にしてみてください。

Sub Sample()
    Dim WB As Workbook
    Dim SH As Worksheet
    Dim i As Long, Lastrow As Long
    Set WB = ActiveWorkbook  'ThisWorkbook
    Set SH = WB.Sheets("転記元シート")
    'セルの色を上から調べて赤色の時の行ナンバーを取得
    '    For i = 1 To Sheets("転記元シート").Cells(Rows.Count, "B").End(xlUp).Row
    '        If Sheets("転記元シート").Cells(i, "B").DisplayFormat.Interior.ColorIndex = 3 Then
    '            Exit For
    '        End If
    '    Next
    '------
    'B列の最終行を転記する場合
    '    For i = 1 To Sheets("転記元シート").Cells(Rows.Count, "B").End(xlUp).Row
    '---
    '選択しているセル(アクティブセルの行№）
    i = ActiveCell.Row
    
    Application.ScreenUpdating = False
    Workbooks.Open Filename:="転記先ブックパス"
    With ActiveSheet  '転記先ブックのアクティブシート
        Lastrow = .Cells(Rows.Count, "B").End(xlUp).Row + 1
        .Cells(Lastrow, "B").Resize(, 3).Value = SH.Cells(i, "B").Resize(, 3).Value
        .Cells(Lastrow, "F").Resize(, 2).Value = SH.Cells(i, "B").Resize(, 2).Value
        .Cells(Lastrow, "I").Resize(, 2).Value = SH.Cells(i, "I").Resize(, 2).Value
    End With
    ActiveWorkbook.Close SaveChanges:=True
    Application.ScreenUpdating = True
    Set SH = Nothing
    Set WB = Nothing
End Sub

転記元シートの最終行はB列を対象にしています。
コメントアウトしているのは、上がセルの色で取得
2番目のコメントがB列の最終行

コメントにしていない　
  i = ActiveCell.Row　はアクティブなセルの行番号です

移したい行を選択してボタンを押すとその行の決められた列が転記先シートの新規行に出力されます。

注意
With ActiveSheet  '転記先ブックのアクティブシート　　になっていますが
開いた転記先ブックの転記先シートが必ずアクティブになっている保証はありませんので、Sheets("転記先シート").Activate のように入れ、さらにシートが存在しない時のエラー処理を入れた方が良いと思います。

ご不明な点がありましたら補足でお願いします。

Qchan1962 · Answer

こんにちは、

少しご質問で判らない所があります。

＞①転記元シートにある「転記ボタン」を押す
OK
＞②各色と同じセルの内容がコピーされて、転記先シートに転記される
例ですと3色を分けて実行すると言う事でしょうか？
例えば赤だけ、黄色と青色同時にとか、、すべてとか
一行になっていますが、同じ色が複数行あると言う事もあるのでしょうか？

③転記先シートには自動で上の行から順番に転記されていく
コードですとA列を最終行取得する行にしていますが、
色ごとにばらばらではないのでしょうか？
A列は何かが必ず入力されるのでしょうか？

＞Paste:=xlPasteValues
になっていますが、書式のコピーは不要？なのでしょうか？

＞Range(Cells(), Cells()).Copy
ここが分からないと言う事でしょうか？
飛んでいるセルなので分けて

Range(Cells(i, "B"), Cells(i, "D"))
Range(Cells(i, "F"), Cells(i, "G"))
Range(Cells(i, "I"), Cells(i, "J"))

xlPasteValuesなのでコピーでなく代入（参照）式で書く場合。

Sub a()
    Dim WB As Workbook
    Dim i As Long
    Set WB = ActiveWorkbook
    For i = 1 To Sheets("転記元シート").Cells(Rows.Count, "B").End(xlUp).Row
        If Sheets("転記元シート").Cells(i, "B").DisplayFormat.Interior.ColorIndex = 3 Then
            Exit For
        End If
    Next
    Workbooks.Open Filename:= _
            "転記先ブックのパス"
    Dim Lastrow As Long
    With ActiveSheet
        Lastrow = .Cells(Rows.Count, 1).End(xlUp).Row

.Range(Cells(Lastrow, "B"), Cells(Lastrow, "D")).Value = _
                WB.Sheets("転記元シート").Range(Cells(i, "B"), Cells(i, "D")).Value
        .Range(Cells(Lastrow, "F"), Cells(Lastrow, "G")).Value = _
                WB.Sheets("転記元シート").Range(Cells(i, "F"), Cells(i, "G")).Value
        .Range(Cells(Lastrow, "I"), Cells(Lastrow, "J")).Value = _
                WB.Sheets("転記元シート").Range(Cells(i, "I"), Cells(i, "J")).Value

ActiveWorkbook.Close SaveChanges:=True
    End With

WBはVBA実行ブック
iは変数　転記元シートの対象セル色で分岐して行№を取得し代入します。
とりあえず。

マクロの転記について教えてください

.Cells(Lastrow + 1, 1).Select

#1です

こんにちは、

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング