エクセルマクロでデータを転記するコードについて

Question

前提・実現したいこと

別ブックにデータを転記するコードを書いたのですが、
下記のコードを動かすと画像の通り最後の値が全体に転記されてしまいうまくいきません

↓

下記コードのどこを直せばうまくいくでしょうか
また、できれば新しいブックに転記する際に、自分のコードだと
転記する範囲を指定していますが、最終行を取得する方法？に変えて
範囲をその都度指定しなくて済むようにしたいです。
よろしくお願いいたします。

該当のソースコード

Sub ボタン1_Click()
Dim c As Range
Set c = Range("C34:C39")
Dim d As Range
Set d = Range("D34:D39")
Dim e As Range
Set e = Range("E34:E39")
Dim f As Range
Set f = Range("F34:F39")
Dim i As Integer

For i = 1 To d.Cells.Count
If d.Cells(i).Value = "〇" Then

Windows("転記.xlsx").Activate

Dim a As Range
Set a = Range("A2:A4")
Dim b As Range
Set b = Range("B2:B4")
Dim g As Range
Set g = Range("C2:C4")
Dim h As Range
Set h = Range("D2:D4")
Dim k As Integer
For k = 1 To a.Cells.Count

a.Cells(k).Value = Date
b.Cells(k).Value = c.Cells(i).Value
g.Cells(k).Value = e.Cells(i).Value
h.Cells(k).Value = f.Cells(i).Value

Next k
End If
Next i
End Sub

Answer 1

最終行の取得方法は大きく２二通りのやり方があります。

その１
変数=cells(rows.count,1).End(xlup).row
rows.countは最終行までジャンプしなさいという命令です。
cells(1048576,1)と指定したのと同じ事です。

その２
変数= Range("A1").End(xlDown).Row

Xlupは「Ctrl+↑」
XlDownは「Ctrl+↓」
のキー操作になります。

上から次の空白セルを見つける方法と下から空白セルを見つける方法になりますが、使い方は
元データの途中に空白があれば、下から上げる。
空白がなければ、どちらでも構いません。
しかし、元データに万が一空白がでるようなケースもあるので、下から上げる方が安全です。

下上げる場合次のようなコードでも可能です。

変数= Range("A1048576").End(xlup).Row
変数= Range("A" & rows.count).End(xlup).row

変数=cells(1048576,1).End(xlup).Row

としても最終行から次の空白セルを取得可能です。

Answer 2

最終行を取得する方法は、

Dim Endrow as long
Endrow =cells(rows.count,1).end(xlup).row

とかです。
アクティブシートの最終行を取得することになりますが、特定のシートの最終行を取得する場合は、Sheets("シート名").cell.... とかになります。

転記についてですが、配列に入れてしまった方が早い気がします。

Sub ボタン1_Click()
Dim a() As Variant
Dim Endrow As Long
Dim i As Long
Dim i2 As Long

Endrow = Cells(Rows.Count, 1).End(xlUp).Row

ReDim a(1 To Endrow, 1 To 6)
For i = 1 To Endrow
  For i2 = 1 To 6
    a(i, i2) = Cells(i, i2)
  Next i2
Next i


Windows("転記.xlsx").Activate
i2 = 1
For i = 1 To Endrow
  If a(i, 4) = "○" Then
     cells(i2,1)=Date
     cells(i2,2)=a(i,3)
     cells(i2,3)=a(i,5)
     cells(i2,4)=a(i,6)
    i2 = i2 + 1
  End If
Next i
End Sub

もっと言うと、データ範囲を取得してしまえば、最終行を取得する必要すらありません。

Sub ボタン1_Click()
Dim a As Variant
Dim i As Long
Dim i2 As Long

a = Cells(1, 1).CurrentRegion

Windows("転記.xlsx").Activate

i2 = 2
For i = LBound(a) To UBound(a) 'LBound(),UBound()はそれぞれ配列の最小と最大の要素の添え字を返す関数です。
  If a(i, 4) = "○" Then
     cells(i2,1)=Date
     cells(i2,2)=a(i,3)
     cells(i2,3)=a(i,5)
     cells(i2,4)=a(i,6)
    i2 = i2 + 1
  End If
Next i
End Sub

Answer 3

今のコードでは、"〇" が見つかる都度、毎回 For k = 1 To a.Cells.Count とやって２～４行目に書き出しています。
毎回同じ場所に上書きすることになるので、処理後は最後の結果だけが残るのです。

これを、できるだけ元の形を残して直すとしたら

Sub ボタン1_Click()
Dim c As Range
Set c = Range("C34:C39")
Dim d As Range
Set d = Range("D34:D39")
Dim e As Range
Set e = Range("E34:E39")
Dim f As Range
Set f = Range("F34:F39")
Dim i As Integer

Dim k As Integer
k = 1

For i = 1 To d.Cells.Count
If d.Cells(i).Value = "〇" Then

Windows("転記.xlsx").Activate

Dim a As Range
Set a = Range("A2:A4")
Dim b As Range
Set b = Range("B2:B4")
Dim g As Range
Set g = Range("C2:C4")
Dim h As Range
Set h = Range("D2:D4")

a.Cells(k).Value = Date
b.Cells(k).Value = c.Cells(i).Value
g.Cells(k).Value = e.Cells(i).Value
h.Cells(k).Value = f.Cells(i).Value

k = k + 1
End If
Next i
End Sub

のような感じにしたらよいと思います。（k の扱いを変えたのが分かると思います。）