• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Macro to copy rows based on cell color and paste the on specified sheets.

N

NoelNoel

New Member
Hello Everyone,

My name is Noel and I am in need of help in creating a macro to copy rows based on cell color from a specific row and paste them to their assigned sheets. I have attached a sample workbook with this post.
 

Attachments

Hello Noel
What is the logic of the process of copying?
How can you determine which row to go to specific sheet .. what is the basis for the sheets?
It is better to attach your expected results

Try this
Code: 
Sub Test()
    Dim I As Integer
    For I = 2 To 6
        Sheet1.Range("A" & I & ":Q" & I).Copy Sheets(I).Range("A" & Sheets(I).Cells(Rows.Count, "B").End(xlUp).Row + 1)
    Next I
End Sub
 
Last edited:
Hi Noel, and welcome to the forum! :awesome:

Rather than trying to detect color, we can use the same rule that the Conditional Formatting it using to determine where to put the info.
This macro will append data from the first sheet onto the other sheets (won't write over previous data)

Code: 
Sub TransferData()
Dim nCount As Integer
Dim myRange
Dim xRow As Long
Dim lastRow As Long
Dim ws As Worksheet

'Where is the data to split out?
Set myRange = Worksheets("Main Data").Range("A2:Q10")

Application.ScreenUpdating = False

For xRow = 1 To myRange.Rows.Count
    'Split things out based on number of N in range
    nCount = WorksheetFunction.CountIf(myRange.Rows(xRow).Range("M1:Q1"), "N")
    Set ws = Nothing
   
    Select Case nCount
   
    Case 1
        Set ws = Worksheets("ONE")
    Case 2
        Set ws = Worksheets("TWO")
    Case 3
        Set ws = Worksheets("THREE")
    Case 4
        Set ws = Worksheets("FOUR")
    Case 5
        Set ws = Worksheets("FIVE")
    Case Else
        'If 0, what do we do?
    End Select
   
    If Not ws Is Nothing Then
        With ws
            lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
            'Error check
            If lastRow = 1 Then
                lastRow = 2
            End If
           
            myRange.Rows(xRow).Copy .Cells(lastRow, "A")
        End With
    End If
Next xRow

Application.ScreenUpdating = True
   
End Sub
 
YasserKhalil said:
Hello Noel
What is the logic of the process of copying?
How can you determine which row to go to specific sheet .. what is the basis for the sheets?
It is better to attach your expected results

Try this
Code: 
Sub Test()
    Dim I As Integer
    For I = 2 To 6
        Sheet1.Range("A" & I & ":Q" & I).Copy Sheets(I).Range("A" & Sheets(I).Cells(Rows.Count, "B").End(xlUp).Row + 1)
    Next I
End Sub
Click to expand...

Hello YasserKhalil,
Thank you for the quick response. Let me see if I can give you the correct information.
The logic to the process is to keep the rest of the spreadsheets updated. I have other co-workers that use the workbook and some times they update the spreadsheets unexpectedly and I want to have a macro to update the spreadsheets with out me going one by one to see if everything is updated. The main sheet will have several hundred rows of information of students and is good to separate the data to their perspective sheets.
I have attached a sample workbook so you can have a better vision on what I am talking about.
Again thank you for response.
 

Attachments

Luke M said:
Hi Noel, and welcome to the forum! :awesome:

Rather than trying to detect color, we can use the same rule that the Conditional Formatting it using to determine where to put the info.
This macro will append data from the first sheet onto the other sheets (won't write over previous data)

Code: 
Sub TransferData()
Dim nCount As Integer
Dim myRange
Dim xRow As Long
Dim lastRow As Long
Dim ws As Worksheet

'Where is the data to split out?
Set myRange = Worksheets("Main Data").Range("A2:Q10")

Application.ScreenUpdating = False

For xRow = 1 To myRange.Rows.Count
    'Split things out based on number of N in range
    nCount = WorksheetFunction.CountIf(myRange.Rows(xRow).Range("M1:Q1"), "N")
    Set ws = Nothing
 
    Select Case nCount
 
    Case 1
        Set ws = Worksheets("ONE")
    Case 2
        Set ws = Worksheets("TWO")
    Case 3
        Set ws = Worksheets("THREE")
    Case 4
        Set ws = Worksheets("FOUR")
    Case 5
        Set ws = Worksheets("FIVE")
    Case Else
        'If 0, what do we do?
    End Select
 
    If Not ws Is Nothing Then
        With ws
            lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
            'Error check
            If lastRow = 1 Then
                lastRow = 2
            End If
         
            myRange.Rows(xRow).Copy .Cells(lastRow, "A")
        End With
    End If
Next xRow

Application.ScreenUpdating = True
 
End Sub
Click to expand...
 
Hello Luke,
Thank for the quick response. I did not know if that would be an option of using the same rule of the conditional formatting that I am using. I have tried the code you created and it works but it only give me data of one student but it does append the date to their specific sheets. The workbook will vary between several hundred students. I have attached the workbook with the code so you can see the results.
 

Attachments

Oops, I goofed! I forgot to add 1 to the last row...it was just pasting into row 2 again and again. :(

Corrected code
Code: 
Sub TransferData()
Dim nCount As Integer
Dim myRange
Dim xRow As Long
Dim lastRow As Long
Dim ws As Worksheet

'Where is the data to split out?
Set myRange = Worksheets("Main Data").Range("A2:Q355")

Application.ScreenUpdating = False

For xRow = 1 To myRange.Rows.Count
    'Split things out based on number of N in range
   nCount = WorksheetFunction.CountIf(myRange.Rows(xRow).Range("M1:Q1"), "N")
    Set ws = Nothing
   
    Select Case nCount
   
    Case 1
        Set ws = Worksheets("ONE")
    Case 2
        Set ws = Worksheets("TWO")
    Case 3
        Set ws = Worksheets("THREE")
    Case 4
        Set ws = Worksheets("FOUR")
    Case 5
        Set ws = Worksheets("FIVE")
    Case Else
        'If 0, what do we do?
   End Select
   
    If Not ws Is Nothing Then
        With ws
            lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
           
            myRange.Rows(xRow).Copy .Cells(lastRow, "A")
        End With
    End If
Next xRow

Application.ScreenUpdating = True
   
End Sub
 
Luke M said:
Oops, I goofed! I forgot to add 1 to the last row...it was just pasting into row 2 again and again. :(

Corrected code
Code: 
Sub TransferData()
Dim nCount As Integer
Dim myRange
Dim xRow As Long
Dim lastRow As Long
Dim ws As Worksheet

'Where is the data to split out?
Set myRange = Worksheets("Main Data").Range("A2:Q355")

Application.ScreenUpdating = False

For xRow = 1 To myRange.Rows.Count
    'Split things out based on number of N in range
   nCount = WorksheetFunction.CountIf(myRange.Rows(xRow).Range("M1:Q1"), "N")
    Set ws = Nothing
 
    Select Case nCount
 
    Case 1
        Set ws = Worksheets("ONE")
    Case 2
        Set ws = Worksheets("TWO")
    Case 3
        Set ws = Worksheets("THREE")
    Case 4
        Set ws = Worksheets("FOUR")
    Case 5
        Set ws = Worksheets("FIVE")
    Case Else
        'If 0, what do we do?
   End Select
 
    If Not ws Is Nothing Then
        With ws
            lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
         
            myRange.Rows(xRow).Copy .Cells(lastRow, "A")
        End With
    End If
Next xRow

Application.ScreenUpdating = True
 
End Sub
Click to expand...

Hello Luke,

Thanks for the help.
It works great. You guys are awesome.
Is there a way to incorporate a code to sequentially number the rows to the last active row.
 
You're very welcome.

Probably. Can you paste a picture of what you mean (would like to see)?
 
Luke M said:
You're very welcome.

Probably. Can you paste a picture of what you mean (would like to see)?
Click to expand...

I uploaded the sample workbook and in spreadsheet ONE you will be able to see what I am talking about but beside that when the code is activated it copies the rows the way it should and perfectly.
 

Attachments

Thanks. Code changed slightly
Code: 
Sub TransferData()
Dim nCount As Integer
Dim myRange
Dim xRow As Long
Dim lastRow As Long
Dim ws As Worksheet

'Where is the data to split out?
Set myRange = Worksheets("Main Data").Range("A2:Q355")

Application.ScreenUpdating = False

For xRow = 1 To myRange.Rows.Count
    'Split things out based on number of N in range
  nCount = WorksheetFunction.CountIf(myRange.Rows(xRow).Range("M1:Q1"), "N")
    Set ws = Nothing
   
    Select Case nCount
   
    Case 1
        Set ws = Worksheets("ONE")
    Case 2
        Set ws = Worksheets("TWO")
    Case 3
        Set ws = Worksheets("THREE")
    Case 4
        Set ws = Worksheets("FOUR")
    Case 5
        Set ws = Worksheets("FIVE")
    Case Else
        'If 0, what do we do?
  End Select
   
    If Not ws Is Nothing Then
        With ws
            lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
           
            myRange.Rows(xRow).Copy .Cells(lastRow, "A")
            'Renumber rows
            .Cells(lastRow, "A").Value = lastRow - 1
        End With
    End If
Next xRow

Application.ScreenUpdating = True
   
End Sub
 
Luke M said:
Thanks. Code changed slightly
Code: 
Sub TransferData()
Dim nCount As Integer
Dim myRange
Dim xRow As Long
Dim lastRow As Long
Dim ws As Worksheet

'Where is the data to split out?
Set myRange = Worksheets("Main Data").Range("A2:Q355")

Application.ScreenUpdating = False

For xRow = 1 To myRange.Rows.Count
    'Split things out based on number of N in range
  nCount = WorksheetFunction.CountIf(myRange.Rows(xRow).Range("M1:Q1"), "N")
    Set ws = Nothing
  
    Select Case nCount
  
    Case 1
        Set ws = Worksheets("ONE")
    Case 2
        Set ws = Worksheets("TWO")
    Case 3
        Set ws = Worksheets("THREE")
    Case 4
        Set ws = Worksheets("FOUR")
    Case 5
        Set ws = Worksheets("FIVE")
    Case Else
        'If 0, what do we do?
  End Select
  
    If Not ws Is Nothing Then
        With ws
            lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
          
            myRange.Rows(xRow).Copy .Cells(lastRow, "A")
            'Renumber rows
            .Cells(lastRow, "A").Value = lastRow - 1
        End With
    End If
Next xRow

Application.ScreenUpdating = True
  
End Sub
Click to expand...


Thank you Luke,
The code works just perfect.
Your work is very appreciated. I will be buying you some drinks.

Thank you so much.
 
You must log in or register to reply here.
Back
Top