Copy range in row based on criteria and paste to another row based on criteria

[mrse]

Hi,
I'm having difficulty coming up with code. Every month a list of stores are created. Information gets reported and updated in cells G to AA until the store project is completed. I've put some formulas in AB -AD to determine whether the store project is completed and will list "Not Completed" in cell AD if the project is still open. I need to develop code to look for "Not Completed" in AD, Copy range G:AA in same row, take store # in column D of the same row, look for that store number in the next month (Column A lists month for every store and gets repeated each month (value not text)) and then paste G:AA to that row.

[mrse]

Here's my test file and the code I have got.



Sub CopyOpen()

Dim lastrow As Long
Dim nextrow As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
nextrow = Cells(Rows.Count, "A").End(xlUp).Row + 1

Application.ScreenUpdating = False

With ActiveSheet
.AutoFilterMode = False
.Range("A1:AD" & lastrow).AutoFilter field:=30, Criteria1:="=Not Completed"
.Range("A2:AA" & lastrow).SpecialCells(xlCellTypeVisible).Copy
.Range("A" & nextrow).PasteSpecial Paste:=xlValues
.AutoFilterMode = False
End With

Application.ScreenUpdating = True

End Sub

Month	B	C	Store#	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	Completed
1	Japan	141	1		12																1				PO	11/16/2015
1	Japan	141	2		12																1				A	11/16/2015
1	Japan	141	3		12																1				A	11/16/2015
1	Japan	141	4		12	C	11/25/2015		$ 1.00	11/25/2015		C	11/25/2015		$ 1.00						1		12345		A	11/16/2015	11/20/2015	Not Completed
1	Japan	141	5		12																1				A	11/16/2015
1	Japan	141	6		12																1				A	11/16/2015
1	Japan	141	7		12																1				A	11/16/2015
2	Japan	141	1		12																1				PO	11/20/2015
2	Japan	141	2		12																1				A	11/20/2015
2	Japan	141	3		12																1				A	11/20/2015
2	Japan	141	4		12																1				A	11/20/2015
2	Japan	141	5		12																1				A	11/20/2015
2	Japan	141	6		12																1				A	11/20/2015
2	Japan	141	7		12																1				A	11/20/2015
3	Japan	141	1		12																2				A	11/21/2015
3	Japan	141	2		12																3				A	11/22/2015
3	Japan	141	3		12																4				A	11/23/2015
3	Japan	141	4		12																5				A	11/24/2015
3	Japan	141	5		12																6				A	11/25/2015
3	Japan	141	6		12																7				A	11/26/2015
3	Japan	141	7		12																8				A	11/27/2015
1	Japan	141	4		12	C	11/25/2015		$ 1.00	11/25/2015		C	11/25/2015		$ 1.00						1		12345		A	11/16/2015

Correct row is copied. However I really want to take the store value in D and paste in the next row that has the same store #. In this case it would be row 12. Is this even possible?

[mrse]

So I've looked up different code and put together. This is the direction I'm going in. There is an error Any suggestions?? Maybe an easier way to do what I'm looking for. I'm stuck! Please help

Sub FindStoreNum()
Dim LSearchRow As Integer
Dim fndrng As Range
Dim StoreNum As Long
On Error GoTo Err_Execute
'Start search at row 2
LSearchRow = 2
While Len(Range("AD" & CStr(LSearchRow)).Value) > 0
'If Column AD is "Not Completed copy rows G:AA in that column
If Range("AD" & CStr(LSearchRow)).Value = "Not Completed" Then
    'Set StoreNum to value of cell to the right of AD
    StoreNum = ActiveCell.Offset(, 1).Value
    Range("G:AA").Select
    Selection.Copy
    
        'Find StoreNum in the Sheet (Should be in Column D)
        Set fndrng = .Cells.Find(What:=StoreNum, After:=ActiveCell, _
            LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            
            If Not fndrng Is Nothing Then
               Range("D:D").Value = fndrng.Value
            
            Else
               MsgBox "Not Found"
            End If
            'Once StoreNum is found paste the copied range to the right (3 Columns)
            Active Cell.Offset(, 3).Paste
End If
'Move to the next row where Not Completed if found
LSearchRow = LSearchRow + 1
Wend
Application.CutCopyMode = False
Err_Execute:
    MsgBox "An error occured."
    
        
End Sub

[mrse]

Please help... I've got the code to work but I want to cut not copy or clear contents of the area I copied. Also if I have multiple rows that meet the criteria it copies all rows but the last one gets duplicated to the next blank row.

	


	
Sub Data_Button1_Click()
    Dim strCopy As String
    Dim strOutput As String
    Dim fCol As Integer
    Dim fRow As Integer
    Dim ws As Worksheet
    Dim dLastRow As Integer
    Dim dFirstRow As Integer
    Dim lRow As Integer
    Dim i As Integer
    Dim dh As Worksheet
    Dim chkData As String
    Dim compData As String
    Dim dFound As Boolean
    Dim cFirstRow As Integer
    Dim cLastRow As Integer
    Dim d As Integer
    Dim LSearchRow As Integer
    Dim findtext As String
    
    
    
    Dim strMth As Long
    Dim strStore As Long
    Dim strdMth As Long
    Dim strdStore As Long
    
    
        
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Set dh = Sheets("Data")
    
    'Initialize Range Variables
    dFound = False
    
    findtext = "Not Completed"
    
    With dh
        dLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        dFirstRow = 1
    End With
        
    With dh
        cLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        cFirstRow = i + 1
    End With
    
    For i = dFirstRow To dLastRow
        If Cells(i, 30).Value = findtext Then
            strStore = Cells(i, "D").Value
            strMth = Cells(i, "A").Value
        
    
                     
             For d = cFirstRow To cLastRow
                 If Cells(d, 4).Value = strStore And Cells(d, 1).Value = strMth + 1 Then
                    dFound = True
                    Exit For
                End If
        
            Next
        
        If dFound = True Then
            'Copy Range First range
            strCopy = "E" & i
            strOutput = "E" & d
            dh.Range(strCopy).Copy
            dh.Range(strOutput).PasteSpecial xlPasteValues
                     
            
            'Copy Range Second Range
            strCopy = "X" & i
            strOutput = "X" & d
            dh.Range(strCopy).Copy
            dh.Range(strOutput).PasteSpecial xlPasteValues
            
            
            'Copy Range Third Range
            strCopy = "G" & i & ":T" & i
            strOutput = "G" & d & ":T" & d
            dh.Range(strCopy).Copy
            dh.Range(strOutput).PasteSpecial xlPasteValues
                     
        
                      
            
            'Copy Date
           ' strCopy = "D4"
           ' strOutput = "AB" & d
            'ws.Range(strCopy).Copy
            'dh.Range(strOutput).PasteSpecial xlPasteValues
        
            
            
        Else
            MsgBox "Une erreur s'est produite. Le magasin " & ws.Range(strStore).Value & " n'a pu être mis à jour. // An error occurred. Unable to update information for store number " & ws.Range(strStore).Value
        End If
      
End If
 Next
 
  Application.EnableEvents = True
 Application.ScreenUpdating = True
 

End Sub