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".

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!

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!