forループVBA Excelの条件付きで行をコピーして貼り付ける方法

Question

次のコードを使用して、リストを別のワークシートに動的にコピーしようとしています。実行されますが、コピーするのではなく、ソースワークシート上の列Eをすべて削除し、コピー先のワークシートには何も移動しません。私は何が起こっているかわからない、何か提案？

Option Explicit 

Sub findCells() 

Dim topCell As String 
Dim leftCell As String 
Dim refCell As Range 
Dim sht As Worksheet 
Dim lastRow As Long 
Dim i As Long 

Set refCell = ActiveCell 

topCell = refCell.End(xlUp).Value 
leftCell = refCell.End(xlToLeft).Value 

MsgBox topCell 
MsgBox leftCell 

Worksheets(topCell).Activate 

Set sht = Worksheets(topCell) 

lastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row 
MsgBox lastRow 

For i = 1 To lastRow 
    Dim cellVal As String 
    Dim altCounter As Integer 
    altCounter = 31 
    Cells(i, 5).Value = cellVal 
    If leftCell = cellVal Then 
    Dim crange As Range 
    altCounter = altCounter + 1 
    Let crange = "A" & i & ":" & "G" & i 
    Range(crange).Copy Worksheets("Summary").Range("A" & altCounter & ":" & "G" & altCounter) 
    End If 
Next i 

End Sub 

Answer 1

これは完全な答えではないですが、あなたはあなたのFor i = 1 To lastRowループ内で多少の誤差がある（と、それはコメントとして書くことが長すぎるのです）。

まず、とRangeを定義済みのshtオブジェクトで完全修飾します。

第2に、ループを入力するたびに変数（cellVal、altCounterおよびcrange）を宣言する必要はありません。

第3に、範囲を設定するには、Let crange = "A" & i & ":" & "G" & iがエラーになります。Set crange = .Range("A" & i & ":" & "G" & i)を使用する必要があります。

第四に、ノーどこのコードで、あなたはcellValに値を与えているので、私はCells(i, 5).Value = cellValであなたの構文はcellVal = .Cells(i, 5).Value

Dim cellVal As String 
Dim altCounter As Long '<-- use Long instead of Integer 
Dim crange As Range 

With sht   
    altCounter = 31 
    For i = 1 To lastRow 
     cellVal = .Cells(i, 5).Value 
     If leftCell = cellVal Then 
      altCounter = altCounter + 1 
      Set crange = .Range("A" & i & ":" & "G" & i) 
      crange.Copy Worksheets("Summary").Range("A" & altCounter & ":" & "G" & altCounter) 
     End If 
    Next i 
End With 

Answer 2

これは、同様にコメントのためにあまりにも長いですが、おかげでシャイであることを意図だと思いますRado - これは完全な答えであり、コードは実装した後に機能しました。

ただし、私が以下のように編集した後、動作を停止しました。それはエラーを発生させず、以前と同じように行をコピー＆ペーストしません。

私は何が起こっているのかよく分かりませんが、MsgBoxを使ってコードの一部を検証すると、機能していないループのように見えます。しかし、エラーを蹴ることなく、私は理由を知らない。

Option Explicit 

Sub findCells() 

Dim topCell As String 
Dim leftCell As String 
Dim refCell As Range 
Dim sht As Worksheet 
Dim lastRow As Long 
Dim i As Long 
Dim cellVal As String 
Dim altCounter As Long 
Dim crange As Range 
Dim rangeToDelete As Range 

Set rangeToDelete = Worksheets("Summary").Cells(31, "A").CurrentRegion 
    rangeToDelete.Value = "" 

Set refCell = ActiveCell 

topCell = refCell.End(xlUp).Value 
leftCell = refCell.End(xlToLeft).Value 

Set sht = Worksheets(topCell) 

lastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row 

With sht 
    .Range("A1:G1").Copy Worksheets("Summary").Range("A31:G31") 
    altCounter = 31 
    For i = 1 To lastRow 
     cellVal = Cells(i, 5).Value 
     If leftCell = cellVal Then 
      altCounter = altCounter + 1 
      Set crange = .Range("A" & i & ":" & "G" & i) 
      crange.Copy Worksheets("Summary").Range("A" & altCounter & ":" & "G" & altCounter) 
     End If 
    Next i 
End With 

End Sub