VBAで結合セルを転記する法を教えてください

シート１、シート２ともA列からG列までが結合セルになっています。
シート１のG列のAAが含まれる行をシート２に図のように転記するVBAを教えてください。

質問者からの補足コメント

• WindFaller　様　GooUserラック 様
  お礼が遅れてすみませんでした。
  私の質問の仕方が悪くてすみません。
  ご両者の回答で質問のファイルは思い通りに動きました。
  実際のファイルは1行目にタイトル行があり、データは3行目からになっていて、表示の右側にもあと数列のデータが入っています。
  ご両者の構文を手直しして試みましたが、実力不足で思うように動かすことができませんでした。
  データは下図のようになっており、I列以降にも何列かのデータが入っています。

  
    補足日時：2017/02/19 08:56

No.4 ベストアンサー 回答者： GooUserラック 回答日時： 2017/02/19 09:03

以下のように修正してください。

------------------------------------------------------------------------------
Sub Sample()
Dim 元行 As Long
Dim 先行 As Long
Sheets("Sheet2").Select
Range(Cells(3, 1), Cells(Rows.Count, Columns.Count)).ClearContents
Sheets("Sheet1").Select
先行 = 3
For 元行 = 3 To Cells(Rows.Count, 7).End(xlUp).Row Step 2
If Cells(元行, 7).Value = "AA" Then
Range(Cells(元行, 1), Cells(元行 + 1, Columns.Count)).Copy
Sheets("Sheet2").Select
Cells(先行, 1).Activate
ActiveSheet.Paste
先行 = 先行 + 2
Sheets("Sheet1").Select
End If
Next
Application.CutCopyMode = False
End Sub
------------------------------------------------------------------------------

この回答へのお礼

GooUserラック 様
回答ありがとうございました。
お陰様で思い通りの動作ができる表ができました。

お礼日時：2017/02/19 16:49

No.6 回答者： GooUserラック 回答日時： 2017/02/19 10:25

No.5 の追加です。

ループなどを使って範囲指定する時は「Range("左上列記号左上行番号:右下列記号右下行番号")」ではなく「Range(Cells(左上行番号,左上列番号),Cells(右下行番号,右下列番号))」を良く使います。こちらも列を数字で指定できるのでループが簡単に出来るからです。

No.5 回答者： GooUserラック 回答日時： 2017/02/19 10:13

回答ではありません。

No.3とNo.4 の一部解説です。

ループなどを使ってセルを指定する時は「Range("列記号行番号")」ではなく「Cells(行番号,列番号)」を良く使います。列を数字で指定できるのでループが簡単に出来るからです。
ちなみに「オプション」「数式」「数式の処理」「R1C1 参照形式を使用する」にチェックを入れると列記号ではなく列番号で表示されるようになります。（プログラムを組む時に変えたままにして怒られた事があります）

「Rows.Count」はエクセルの最終行番号です。
「Columns.Count」はエクセルの最終列番号です。
エクセルのバージョンに合わせて変わってくれるので2003以前とか2007以降とか気にせず使えます。

「Cells(Rows.Count, 列番号).End(xlUp).Row」は列番号で指定された列の値の入っている最終行になります。注意点は、列に何もない時も１行目にだけ値が入っている時も「1」になります。

No.3 回答者： GooUserラック 回答日時： 2017/02/16 17:33

とりあえずこんな形で良いのでは？

------------------------------------------------------------------------------
Sub Sample()
Dim 元行 As Long
Dim 先行 As Long
Sheets("Sheet2").Select
Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).ClearContents
Sheets("Sheet1").Select
先行 = 2
For 元行 = 2 To Cells(Rows.Count, 7).End(xlUp).Row Step 2
If Cells(元行, 7).Value = "AA" Then
Range(Cells(元行, 1), Cells(元行 + 1, Columns.Count)).Copy
Sheets("Sheet2").Select
Cells(先行, 1).Activate
ActiveSheet.Paste
先行 = 先行 + 2
Sheets("Sheet1").Select
End If
Next
Application.CutCopyMode = False
End Sub
------------------------------------------------------------------------------

No.2 回答者： WindFaller 回答日時： 2017/02/16 17:32

マクロなら、この程度で良いかと思います。

'//標準モジュール
Sub MergeCellsCopy()
　Dim c, k As Long
　Dim sh1 As Worksheet, sh2 As Worksheet
　Set sh1 = Worksheets("Sheet1")
　Set sh2 = Worksheets("Sheet2")
　k = 1
　Application.ScreenUpdating = False
　With sh1
　　For Each c In .Range("G2", .Cells(Rows.Count, "G").End(xlUp)).Cells
　　　If c.Value Like "AA" Then
　　　　c.EntireRow(1).Resize(2, 7).Copy sh2.Cells(2 + (k - 1) * 2, 1)
　　　　k = k + 1
　　　End If
　　Next
　End With
　Application.ScreenUpdating = True
End Sub

No.1 回答者： 渚美鈴 回答日時： 2017/02/16 17:31

？

抽出のこと？
フィルター使えば？
https://kokodane.com/2013_waza_053.htm