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