複数Excelを一つにまとめる方法

Question

###前提・実現したいこと

フォルダーにExcelデータが複数あり（タイトル・データ1列のみ）
このExcelデータを一つのExcel（マクロ付Excel)にまとめるシステムをVBAにて作成しています。
複数エクセルは、縦型ですがまとめるにあたり横型データに
変換していきたいです。
初心者で、手探り状態で進めています。ご教授頂ける
方がいまたらよろしくお願いします。

###発生している問題・エラーメッセージ

過去にでた文章を張り付けて修正していますが
なかなか上手く作動しません。

###該当のソースコード
###試したこと
Sub データ蓄積3()

Dim Bk As Workbook
Dim Rw As Long, ERw As Long
Const ShName = "Sheet1"
'Const PathN = "各ブックのパス名"
Const FNCom = "問診票" ' <-- ファイル名の先頭共通部分指定
Dim FileN As String
Dim Cnt As Integer
FileN = Dir(PathN & FNCom & "*.xlsx") ' <-- 拡張子を指定
Rw = 1
Application.ScreenUpdating = False
Do Until FileN = ""
Cnt = Cnt + 1
Set Bk = Workbooks.Open(PathN & FileN, ReadOnly:=True)
With ThisWorkbook.Sheets(ShName)

Sheets("Sheet2").Select
If Cnt = 1 Then
' .Cells.Clear
Rows("2:2").Select
Selection.Copy
Windows("問診蓄積データ.xlsm").Activate
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'ShName.Close

' Bk.Sheets(2).Cells.Copy .Range("A2")
' .Rows(2).Insert
' .Range("A2").Value = FileN
' .Columns(1).AutoFit

Else
Windows("問診蓄積データ.xlsm").Activate

Rw = .Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
.Cells(Rw, 1).Value = FileN

ERw = Bk.Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
If ERw > 1 Then Bk.Sheets(2).Range("A" & ERw & ":AG
Windows(FileN).Activate
" & ERw).Copy .Cells(Rw + 1, 1)
End If
Bk.Close
End With
FileN = Dir
Loop
Application.ScreenUpdating = True
MsgBox Cnt & " 個のブックのデータを集合しました。", vbInformation
Set Bk = Nothing
End Sub

###補足情報(言語/FW/ツール等のバージョンなど)
より詳細な情報

Comments

[ttyp03]

「なかなか上手く作動しません。」の部分を詳細に書かないとわかりません。

[beaglerio]

同一フォルダにExcelを2データ用意しました。
蓄積するExcelにVBAを設定し、マクロ組み実行したところ
一つ目のExceデータは、横型で蓄積Excelの2行目にコピーができました。
しかし、二つ目のExcelデータに於いては、"問診票2.xlsx"というタイトルが
３行目に入り、データは４行目に入りましたが列がずれています。

この様な状態です。どうしたら２個目以降のExcelデータが蓄積させられるか
わかりません。つたない説明で申し訳ありません。よろしくお願いいたします。

[ttyp03]

If文のネストがずれているようです。End Ifが足りない。行が抜けてますかね？あとコードは```で括ると綺麗に掲載されます。

Answer 1

貼り付けられているコードが少しおかしいです。おかしい部分を示します。

                If ERw > 1 Then Bk.Sheets(2).Range("A" & ERw & ":AG
                Windows(FileN).Activate
                " & ERw).Copy .Cells(Rw + 1, 1)

ここは、以下のようにWindows(FileN).Activateがずれませんか？

                If ERw > 1 Then Bk.Sheets(2).Range("A" & ERw & ":AG" & ERw).Copy .Cells(Rw + 1, 1)
                Windows(FileN).Activate

それと投稿のコードを```(Shift+@)で囲うように修正してもらえませんか。見づらいので。