Excel VBA copying specific rows and pasting them to specific sheet. Without double inserting the data

[rekasi]

Hello, I am using vba in windows. I have a excel project. I need to have a list of projects, the status of the project color codes the row. Data is sorted by macro that sorts data by its color. I want to have page where all the projects are listed and then one sheet for each status, which are "done" "work in progress" and "discontinued". The problem i am facing is that when I run my the code it deletes it from main registry and if I take the delete row out of the code it will double insert the data. So therefore I am thinking pasting the full table and deleting rows that are not meant to be in ie. "done sheet". Also if I change status in main sheet it should affect sheets with one status only, or at least rearrange sheets to correct places. Can someone help me with the code? I have no idea how to do it, I tried to search other threads, but could not find one with correct code. Thank you in advance. Picture is to help understand what I mean. The text is in finnish dont mind it.

 

[mumps]

It is hard to work with pictures. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

 

[rekasi]

How do I screenshot with xl2bb add in?

 

[rekasi]

Hankerekisterin kopio.xlsm there the dropbox link.

 

[mumps]

Which sheet is the main registry? Where are the values "done", "work in progress" and "discontinued" located? Please explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data.

when I run my the code it deletes it from main registry

Please post this code.

 

[rekasi]

The main registry is "hankerekisteri" and secondaries are "keskeneräiset hankkeet" =work in progress, "valmiit hankkeet"=done, and "peruutetut hankkeet"=discontinued". I want to be able to see red ones in "peruutetut hankkeet" and greens in "valmiit hankkeet" and orange ones in "keskeneräiset hankkeet" and still be able to see all of the projects in "hankerekisteri"

Sub move_rows_to_another_sheet()
For Each myCell In Selection.Columns(6).Cells
If myCell.Value = "kesken" Then
myCell.EntireRow.Copy Worksheets("keskeneräiset hankkeet").Range("A" & Rows.Count).End(3)(2)
myCell.EntireRow.Delete
End If
Next
End Sub

If I take the delete away it will double insert the data from the table "tblhankkeet" in "hankerekisteri"

 

[mumps]

Try:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, v As Variant, i As Long, x As Long
    Set srcWS = Sheets("Hankerekisteri")
    v = srcWS.Range("A4", srcWS.Range("A" & Rows.Count).End(xlUp))
    For i = 1 To UBound(v, 1)
        x = srcWS.Range("A" & i + 3).DisplayFormat.Interior.Color
        With srcWS
            .ListObjects("tblhankkeet").Range.AutoFilter Field:=1, Criteria1:=x, Operator:=xlFilterCellColor
            Select Case x
                Case Is = 49407 'orange
                    With Sheets("Keskeneräiset hankkeet")
                        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                        If LastRow > 3 Then
                            .UsedRange.Rows("4:" & LastRow).Delete
                        End If
                        srcWS.Range("A4", srcWS.Range("I" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy .Range("A4")
                        Application.DisplayAlerts = False
                        srcWS.Range("A4", srcWS.Range("I" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Delete
                        Application.DisplayAlerts = True
                    End With
                Case Is = 9359529 'green
                    With Sheets("Valmiit hankkeet")
                        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                        If LastRow > 3 Then
                            .UsedRange.Rows("4:" & LastRow).Delete
                        End If
                        srcWS.Range("A4", srcWS.Range("I" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy .Range("A4")
                        Application.DisplayAlerts = False
                        srcWS.Range("A4", srcWS.Range("I" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Delete
                        Application.DisplayAlerts = True
                    End With
                Case Is = 13311 'red
                    With Sheets("Peruutetut hankkeet")
                        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                        If LastRow > 3 Then
                            .UsedRange.Rows("4:" & LastRow).Delete
                        End If
                        srcWS.Range("A4", srcWS.Range("I" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy .Range("A4")
                        Application.DisplayAlerts = False
                        srcWS.Range("A4", srcWS.Range("I" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Delete
                        Application.DisplayAlerts = True
                    End With
            End Select
        End With
    Next i
    srcWS.ListObjects("tblhankkeet").Range.AutoFilter
    Application.ScreenUpdating = True
End Sub

 

[rekasi]

It's almost perfect, but I need to see all the information from "hankerekisteri". Maybe one solution to this would be that code first clears the data in sub registeries and then pastes it. Due all the changes to data must be made in main reistry, "hankerekisteri"

 

[mumps]

Try:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, v As Variant, i As Long, x As Long
    Set srcWS = Sheets("Hankerekisteri")
    v = srcWS.Range("A4", srcWS.Range("A" & Rows.Count).End(xlUp))
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v, 1)
            x = srcWS.Range("A" & i + 3).DisplayFormat.Interior.Color
            If Not .exists(x) Then
                .Add x, Nothing
                With srcWS
                    .ListObjects("tblhankkeet").Range.AutoFilter Field:=1, Criteria1:=x, Operator:=xlFilterCellColor
                    Select Case x
                        Case Is = 49407 'orange
                            With Sheets("Keskeneräiset hankkeet")
                                LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                                If LastRow > 3 Then
                                    .UsedRange.Rows("4:" & LastRow).Delete
                                End If
                                srcWS.Range("A4", srcWS.Range("I" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy .Range("A4")
                            End With
                        Case Is = 9359529 'green
                            With Sheets("Valmiit hankkeet")
                                LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                                If LastRow > 3 Then
                                    .UsedRange.Rows("4:" & LastRow).Delete
                                End If
                                srcWS.Range("A4", srcWS.Range("I" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy .Range("A4")
                            End With
                        Case Is = 13311 'red
                            With Sheets("Peruutetut hankkeet")
                                LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                                If LastRow > 3 Then
                                    .UsedRange.Rows("4:" & LastRow).Delete
                                End If
                                srcWS.Range("A4", srcWS.Range("I" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy .Range("A4")
                            End With
                    End Select
                End With
            End If
        Next i
    End With
    srcWS.ListObjects("tblhankkeet").Range.AutoFilter
    Application.ScreenUpdating = True
End Sub

 

[rekasi]

It worked thanks mate.