Macro help please!

[ilovrice]

I have an excel file with several sheets. There are several lines in each sheet. The formula =COUNTIF(I:I; I2) goes into the M2 field. That formula should go to all rows where there is data in column I. I need a macro to filter data from column M in the active sheet. Data are numbers. All rows that have a number less than 5 in column M should be copied to a new sheet and name that sheet "LESS". All rows that have a number greater than 4 in the column M should be copied to a new sheet and name that sheet "MORE". I made a macro but it doesn't work as I would like. It copies only the last line to a new sheet. That is, all lines are copied over one. How to solve this? Please some help.

Sub FilterAndCopyData()
Dim ws As Worksheet
Dim lessWs As Worksheet
Dim moreWs As Worksheet
Dim lastRow As Long
Dim cell As Range

' Set references to active sheet and create new sheets
Set ws = ActiveSheet
Set lessWs = ThisWorkbook.Sheets.Add
Set moreWs = ThisWorkbook.Sheets.Add

' Rename the new sheets
lessWs.Name = "LESS"
moreWs.Name = "MORE"

' Find the last row in column I
lastRow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row

' Populate column M with COUNTIF formula
ws.Range("M2:M" & lastRow).Formula = "=COUNTIF(I:I, I2)"

' Loop through the data in column M
For Each cell In ws.Range("M2:M" & lastRow)
If IsNumeric(cell.Value) Then
If cell.Value < 5 Then
' Copy to the "LESS" sheet
cell.EntireRow.Copy lessWs.Cells(lessWs.Cells(Rows.Count, "A").End(xlUp).Row + 1, 1)
Else
' Copy to the "MORE" sheet
cell.EntireRow.Copy moreWs.Cells(moreWs.Cells(Rows.Count, "A").End(xlUp).Row + 1, 1)
End If
End If
Next cell

' Clean up
Application.CutCopyMode = False
End Sub

 

[DanteAmor]

Hi @ilovrice
Welcome to the MrExcel forum. Please accept my warmest greetings and sincere hope that all is well.

That is, all lines are copied over one. How to solve this?

Try:

Sub FilterAndCopyData()
  Dim ws As Worksheet
  Dim lessWs As Worksheet
  Dim moreWs As Worksheet
  Dim lastRow As Long
  Dim cell As Range
  
  ' Set references to active sheet and create new sheets
  Set ws = ActiveSheet
  Set lessWs = ThisWorkbook.Sheets.Add
  Set moreWs = ThisWorkbook.Sheets.Add
  
  ' Rename the new sheets
  lessWs.Name = "LESS"
  moreWs.Name = "MORE"
  
  ' Find the last row in column I
  lastRow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
  
  ' Populate column M with COUNTIF formula
  ws.Range("M2:M" & lastRow).Formula = "=COUNTIF(I:I, I2)"
  
  ' Loop through the data in column M
  For Each cell In ws.Range("M2:M" & lastRow)
    If IsNumeric(cell.Value) Then
      If cell.Value < 5 Then
        ' Copy to the "LESS" sheet
        cell.EntireRow.Copy lessWs.Range("A" & lessWs.Range("M" & Rows.Count).End(xlUp).Row + 1)
      Else
        ' Copy to the "MORE" sheet
        cell.EntireRow.Copy moreWs.Range("A" & moreWs.Range("M" & Rows.Count).End(xlUp).Row + 1)
      End If
    End If
  Next cell
  
  ' Clean up
  Application.CutCopyMode = False
End Sub

----- --
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
----- --

 

[ilovrice]

Works great! Thank you very much! You have a beer when you come to Croatia!

 

[ilovrice]

I have one more question if I may. Apparently I have some kind of problem with personal.xls. When I insert this macro into the worksheet, it works great, but when I insert it into personal.xls so that I can always use it, it starts working for me in personalx.xls, even though my personal is hidden in the worksheet and not in the active worksheet. What am I doing wrong.

 

[DanteAmor]

That's a different topic.
Create a new question for someone to help you configure the macro in personal.xls