集計データを表に持ってくる2

Sub 集計データを表に持ってくる2()
    Dim ws5 As Worksheet
    Set ws5 = Worksheets("CSR集計")
    Dim ws1 As Worksheet
    Set ws1 = Worksheets("貼付")
    Dim lr As Long
    Dim colm As Long
    Dim lr2 As Long
    Dim colm2 As Long
    Dim i As Long
    Dim dtRange As Range
    Dim array1 As Variant

    
    colm = 3
    colm2 = 4
    ' 貼付シートのD列の次の空白行を取得
    lr2 = ws1.Cells(Rows.Count, colm2).End(xlUp).Row + 1
    ' 貼付シートのD列を範として取得
    Set dtRange = ws1.Range(Cells(8, colm2), Cells(lr2 - 1, colm2))
        
    lr = ws5.Cells(Rows.Count, colm).End(xlUp).Row
    array1 = ws5.Range(ws5.Cells(3, colm), ws5.Cells(lr, colm))
    
    ' データをコピーして貼り付け
    For i = 1 To UBound(array1)
    
        If array1(i, 1) >= 1 Then
            ' 数値が1以上かつD列に存在しない場合、左隣のセルの値をD列に追加
            If WorksheetFunction.CountIf(dtRange, ws5.Cells(i + 2, 2).Value) = 0 Then
                ws1.Cells(lr2, colm2).Value = ws5.Cells(i + 2, 2).Value
                lr2 = lr2 + 1
            End If
        End If
    Next i
    
    MsgBox "データが追加されました。", vbInformation
End Sub