VBA code skipping cells, not sure why?

[leal72]

I have this code to find then minimum value in column "C", look through all the cells in "C" with values, if the value matches the minimum I want it to move the row from column "A:D".

In the workbook example you will notice that it works correct on row 1 and 3 but skips row 2.


Sub Macro()
Dim fName As String
Dim lastRow As Long
Dim endRow As Long
Dim cRow As Long
Dim zIndex As Long
Dim zLayer As String
Dim zMin As Double
Dim zCell As Range
fName = ActiveSheet.Name
lastRow = Sheets(fName).Range("AZ1").End(xlDown).Row
endRow = Sheets(fName).Range("C" & lastRow).End(xlUp).Row
For zIndex = 1 To endRow
zLayer = "Layer_" & zIndex
zMin = Application.WorksheetFunction.Min(Sheets(fName).Range("C1:C" & endRow))
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = zLayer
cRow = 1
For Each zCell In Sheets(fName).Range("C1:C" & endRow)
If zCell.Value = zMin Then
Sheets(fName).Range(zCell.Offset(0, -2), zCell.Offset(0, 1)).Cut _
Sheets(zLayer).Range("A" & cRow)
cRow = cRow + 1
End If
Next zCell
Next
End Sub

[ranman256]

probably you are going from 1 to endRow in rows. But if you remove a row , you messed up your counter.
Go from endRow to 1 step -1

[Bob Phillips]

Sub Macro()
Dim sh As Worksheet, sh2 As Worksheet
Dim zRng As Range
Dim lastRow As Long
Dim zLayer As Long
Dim zMin As Double
Application.ScreenUpdating = False
Set sh = ActiveSheet
With sh
zLayer = 1
Do While Application.CountA(.Columns("C")) > 1
lastRow = .Range("C" & .Rows.Count).End(xlUp).Row
zMin = Application.Min(.Columns("C"))
If zMin <> 0 Then
.Rows(1).Insert
.Range("C1").Value = "tmp"
.Columns("A:D").AutoFilter Field:=3, Criteria1:=zMin
Set zRng = .Range("A1").Resize(lastRow, 4).SpecialCells(xlCellTypeVisible)
Set sh2 = Nothing
On Error Resume Next
Set sh2 = Worksheets("Layer_" & zLayer)
On Error GoTo 0
If sh2 Is Nothing Then
Set sh2 = Worksheets.Add(After:=Worksheets(Worksheets.Count))
sh2.Name = "Layer_" & zLayer
Else
sh2.UsedRange.ClearContents
End If
zRng.Copy sh2.Range("A1")
zRng.EntireRow.Delete
sh2.Rows(1).Delete
zLayer = zLayer + 1
End If
Loop
End With
Application.ScreenUpdating = True
End Sub

[leal72]

probably you are going from 1 to endRow in rows. But if you remove a row , you messed up your counter.
Go from endRow to 1 step -1

Thanks for looking but that did not work either, same result. Not processing the second row.

[leal72]

Sub Macro()
Dim sh As Worksheet, sh2 As Worksheet
Dim zRng As Range
Dim lastRow As Long
Dim zLayer As Long
Dim zMin As Double
Application.ScreenUpdating = False
Set sh = ActiveSheet
With sh
zLayer = 1
Do While Application.CountA(.Columns("C")) > 1
lastRow = .Range("C" & .Rows.Count).End(xlUp).Row
zMin = Application.Min(.Columns("C"))
If zMin <> 0 Then
.Rows(1).Insert
.Range("C1").Value = "tmp"
.Columns("A:D").AutoFilter Field:=3, Criteria1:=zMin
Set zRng = .Range("A1").Resize(lastRow, 4).SpecialCells(xlCellTypeVisible)
Set sh2 = Nothing
On Error Resume Next
Set sh2 = Worksheets("Layer_" & zLayer)
On Error GoTo 0
If sh2 Is Nothing Then
Set sh2 = Worksheets.Add(After:=Worksheets(Worksheets.Count))
sh2.Name = "Layer_" & zLayer
Else
sh2.UsedRange.ClearContents
End If
zRng.Copy sh2.Range("A1")
zRng.EntireRow.Delete
sh2.Rows(1).Delete
zLayer = zLayer + 1
End If
Loop
End With
Application.ScreenUpdating = True
End Sub


This works!:thumb

I do appreciate the help.

The individual sheets all look correct, the main worksheet still has a single row with values in it.

I'm going to try and go through this one to see what each line is doing.

Thank you!