VBA If Functions and Copying Rows over to new sheets

[grannybrad]

Hi, I'm having trouble coming up with a way to create a code in VBA that would parse through a table of data, recognize if a value was in between a set of numbers and if it was, copy and paste the row into the next avaiable empty row in the new sheet. Then, if all went well, it would go down to the next value

For reference:

All values in column I are between 3-30

If the value in column I< 5, then I would want to the entire row containing that value to copy to the next empty row in sheet 3-5yr Mat. From there the parameters would be if i is between 5 and 7, 7and 10, 10 and 18 amd greater than 18, with each one of those parameters corresponding to a new sheet


Any tips on how to set up that code?

 

[JLGWhiz]

Hi grannybrad,
Give this a try. Copy the procedure to your standard code module1. Make sure your workbooks is a macroenabled workbook with a .xlsm file extension. The code will add sheets if your workbook has less than six. I would hope that you do not have other sheets filled in the workbook, but if you do, be sure to edit the sheet names that are in the code Set statements.

Sub dist()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, sh4 As Worksheet, sh5 As Worksheet, sh6 As Worksheet
Dim lr As Long, rng As Range, c As Range, sc As Long
sc = ThisWorkbook.Sheets.Count
If sc < 6 Then Sheets.Add After:=Sheets(sc), Count:=6 - sc, Type:=xlWorksheet
Set sh1 = Sheets(1) 'Edit sheet name
Set sh2 = Sheets(2) 'Edit sheet name
Set sh3 = Sheets(3) 'Edit sheet name
Set sh4 = Sheets(4) 'Edit sheet name
Set sh5 = Sheets(5) 'Edit sheet name
Set sh6 = Sheets(6) 'Edit sheet name
lr = sh1.Cells(Rows.Count, 9).End(xlUp).Row 'Get last row with data in column I.
Set rng = sh1.Range("I2:I" & lr) 'Assumes Row 1 as header row
    For Each c In rng
        Select Case c.Value
            Case Is < 5
                c.EntireRow.Copy sh2.Cells(Rows.Count, 1).End(xlUp)(2)
             Case 5 To 7
                c.EntireRow.Copy sh3.Cells(Rows.Count, 1).End(xlUp)(2)
            Case 8 To 10
                c.EntireRow.Copy sh4.Cells(Rows.Count, 1).End(xlUp)(2)
            Case 11 To 18
                c.EntireRow.Copy sh5.Cells(Rows.Count, 1).End(xlUp)(2)
            Case Is > 18
                c.EntireRow.Copy sh6.Cells(Rows.Count, 1).End(xlUp)(2)
        End Select
    Next
End Sub