シートのチェックは必要なさそうなので、コメントアウトしています。
'sh_check

まとめるシートはシート見出しの2番目のシートにしています。
3番目のシートのB6:J6がデータの列見出しなので、コピーして2番目のシートに貼り付け
まとめるシート名は1〜5で　"4"　を除くと仮定しました。面倒ですがコピーするシート名はすべて書き出してください。
Sh = Array("1", "2", "3", "5")
そのほか、lRow、lcolなども修正しています。
以下のコードでいかがですか?

Sub matome2()
Dim Sh
Dim i As Integer
Dim lRow As Long, lCol As Long, lRow2 As Long
Application.ScreenUpdating = False

'sh_check

Worksheets(3).Range("B6:J6").Copy Worksheets(2).Range("A1")

Sh = Array("1", "2", "3", "5")
For i = LBound(Sh) To UBound(Sh)
With Worksheets(Sh(i))
lRow = .Cells(Rows.Count, 2).End(xlUp).Row
lCol = .Cells(6, Columns.Count).End(xlToLeft).Column
If lRow >= 7 Then
lRow2 = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row + 1
.Activate
.Range(Cells(7, 2), Cells(lRow, lCol)).Copy
Worksheets(2).Cells(lRow2, 1).PasteSpecial xlPasteValues
End If
End With
Next i
Worksheets(2).Activate
Range("A1").Select
Application.ScreenUpdating = True
End Sub

データがどのセル範囲にあるのかがこちらでは不明なので、
列見出しのコピーからB6セルからデータがあるのだろうと推測しました。

最終行lRowは　 .Cells(Rows.Count, 2)として、B列で調べています。
最終列lColは　 .Cells(6, Columns.Count)と、６行目で調べています。

以前のままだとA1セル基準で調べていたので、データがないと０になります。
また、データと関係ないことが入力されていたら、
目的のデータの最終行や最終列を求めることができません。


あと、Worksheets(3).Range("B6:J6").Copy Worksheets(2).Range("A1")　は
シート見出しの３番目のシートの列見出しを使うことになっているので、
Sh = Array("1", "2", "3", "5")
Worksheets(Sh(0)).Range("B6:J6").Copy Worksheets(2).Range("A1")
とか、シート名を使うべきと思います。

以上です。

行の削除は最終行から上に向かって実行します。
↓のコードでは、ワークシート関数のCOUNTAで空白を判定しています。

Sub 空白行の削除()
  Dim lRow As Long
  Dim i As Long
    lRow = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row 
    For i = lRow To 6 Step -1
        If WorksheetFunction.COUNTA(Rows(i)) = 0 Then
            Rows(i).Delete
        End If
    Next i
End Sub