VBA - Loop Throuthの場合、各行は機能しません（データセットに変更はありません）

Question

大規模なExcelデータセットを整理しました。ここでは、手順の1つを自動化するマクロを記録します。下のスクリーンショットを見てください。私がしたいのは、上の行の列Fに名前（列C）の下に説明がある場合は、その行の説明を移動させることです。たとえば、C3の値をカットし、それをF2に貼り付けます。私はそれぞれの行をループし、各ループのために使用しますが、私は自分のコードを実行すると何も起こりません

A screenshot of the dataset

。 countblank（）関数を使用して、記述だけを含む行を識別します。ここに私のコードです：

Sub ForEach_Loop() 

Dim ws3 As Worksheet 
Set ws3 = Worksheets("Sheet3") 

Dim CutCell As Integer 
Dim PasteCell As Integer 

CutCell = 2 
PasteCell = 1 

Dim Count_Blank As Integer 
Dim rng As Range 
Dim row As Range 

Set rng = ws3.Range("A1:M300") 

For Each row In rng.Rows 

    Count_Blank = Application.WorksheetFunction.CountBlank(ws3.Range(ws3.Cells(1, CutCell),  ws3.Cells(13, CutCell))) 
    If Count_Blank = 12 Then 
     ws3.Range(ws3.Cells(3, CutCell)).Cut ws3.Range(ws3.Cells(6, PasteCell)) 
    End If 
    CutCell = CutCell + 1 
    PasteCell = PasteCell + 1 
Next row 

End Sub 

私はVBAにはかなり新しいですが、しかし、この作品は本当に時間がかかり、誰でも問題は私のコードであるものを私に伝えることができるのですか？

Answer 1

Sub ForEach_Loop() 

    Dim ws3 As Worksheet 
    Dim row As Range 

    Set ws3 = Worksheets("Sheet3") 

    For Each row In ws3.Range("A2:M300").Rows 

     If Application.CountA(row) = 1 And row.Cells(3).Value <> "" Then 

     With row.Cells(3) 
      row.Cells(6).Offset(-1, 0).Value = .Value 
      .ClearContents 
     End With 

     End If 

    Next row 

End Sub