VBA Excel Automatically Copy & Paste Specific cells based on IF statement - excel

Question

The code I have placed below is a combination of what works and what i can't get to work.
The code that is not commented will copy cells to "sheet2" from "sheet1".
What I cannot get to work correctly is the code that I have disabled that would replace my Range Method of coping from "sheet1" to "sheet2".
Also my If Then Code is what will some up what I'm trying to accomplish. I'm trying to get the If statement to search all of column A and copy all Cars that are year 1991 to sheet2.
Mind my poor coding skills I'm Doing my best to show & explain so I can be helped.
Here is the Sheets 1 & 2
(hxxp://s15.postimg.org/orfw7tlaz/test.jpg)
OLD CODE
Sub Macro1()
Set a = Sheets("Sheet1")
Set b = Sheets("Sheet2")
Set c = Sheets("Sheet3")
Dim x
Dim z
Dim lastrow As Long, erow As Long
x = x + 1
z = 2
'lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
'lastrow = b.Cells(Rows.Count, 1).End(xlUp).Row
'For i = 2 To lastrow
lastrow = b.Range("A" & Rows.Count).End(xlUp).Row + x
'If a.Cells(i, 1) = “1991” Then
'a.Cells(i, 1).Copy
'erow = b.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
'b.Paste Destination:=b.Range.Cells(erow, 4)
Range("A" & z).Copy Destination:=b.Range("D" & lastrow)
'a.Cells(i, 1).Copy
'b.Paste Destination:=b.Range.Cells(erow, 1)
Range("B" & z).Copy Destination:=b.Range("A" & lastrow)
'a.Cells(i, 1).Copy
'b.Paste Destination:=b.Range.Cells(erow, 3)
Range("C" & z).Copy Destination:=b.Range("C" & lastrow)
'a.Cells(i, 1).Copy
'b.Paste Destination:=b.Range(erow, 2)
Range("D" & z).Copy Destination:=b.Range("B" & lastrow)
'End If
'Next i
Application.CutCopyMode = False
Sheet2.Columns().AutoFit
'b.Range("A1").Select
End Sub
So I added some Lines and Began changing the cell locations to reflect the format I need and now when I run the macro it only copys the very last line from Sheet1 to sheet2. I believe it has to do with the order of the way these cells are.
b.Cells(erow, 1) = a.Cells(i, 1)
b.Cells(erow, 2) = a.Cells(i, 2)
b.Cells(erow, 3) = a.Cells(i, 3)
b.Cells(erow, 4) = a.Cells(i, 4)
Changing these back fixes it so it copys all the cells but its not what I'm trying to do.
The Code I'm Trying to run is Below
NEW CODE Working Thanks to EntryLevel!
Sub TakeTwo()
Dim a As Worksheet
Dim b As Worksheet
Dim c As Worksheet
Set a = ThisWorkbook.Sheets("Sheet1")
Set b = ThisWorkbook.Sheets("Sheet2")
Set c = ThisWorkbook.Sheets("Sheet3")
Dim i As Long
Dim lastrowsheet1 As Long
Dim erow As Long
lastrowsheet1 = a.Cells(Rows.Count, 1).End(xlUp).Row
erow = b.Cells(b.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
For i = 2 To lastrowsheet1
If a.Cells(i, 1).Value = "AEM" Then
b.Cells(erow, 31) = a.Cells(i, 1) '<------When I modify these
b.Cells(erow, 6) = a.Cells(i, 4) '<------The copied cells
b.Cells(erow, 28) = a.Cells(i, 5) '<------Don't show up
b.Cells(erow, 26) = a.Cells(i, 6) '<------In Sheet2
b.Cells(erow, 46) = a.Cells(i, 11) '<------Only the last
b.Cells(erow, 29) = a.Cells(i, 14) '<------Line found Is copied to sheet2
erow = erow + 1
End If
Next i
Application.CutCopyMode = False
b.Columns.AutoFit
'b.Range("A1").Select
End Sub
Now Using Same Working Code But Different function Not Working
Sub TakeThree()
Dim a As Worksheet
Dim b As Worksheet
Dim c As Worksheet
Set a = ThisWorkbook.Sheets("Sheet1")
Set b = ThisWorkbook.Sheets("Sheet2")
Set c = ThisWorkbook.Sheets("Sheet3")
Dim i As Long
Dim lastrowsheet1 As Long
Dim erow As Long
lastrowsheet1 = c.Cells(Rows.Count, 1).End(xlUp).Row
erow = b.Cells(b.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
For i = 2 To lastrowsheet1
If c.Cells(i, 1).Value = b.Cells(erow, 6).Value Then 'If serial number is found from sheet2 column 6 in sheet3 Column 1
b.Cells(erow, 8) = c.Cells(i, 2) 'Then copy description from sheet3 cell row to Sheet2 cell row
erow = erow + 1
End If
Next i
Application.CutCopyMode = False
b.Columns.AutoFit
c.Columns.AutoFit
'b.Range("A1").Select
End Sub
So I added another For Loop with Dim r and added another Line erow = erow + r & now the code copys the first 2 rows needed but does not continue iterating down the list. which is confusing me. here is the code below i have added.
Dim r As Long
Dim i As Long
Dim lastrowsheet1 As Long
Dim erow As Long
lastrowsheet1 = c.Cells(Rows.Count, 1).End(xlUp).Row
erow = b.Cells(b.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
For r = 1 To erow
For i = 2 To lastrowsheet1
If c.Cells(i, 1) = b.Cells(erow, 6) Then
b.Cells(erow, 8) = c.Cells(i, 2)
erow = erow + r
End If
Debug.Print i
Next i
Next r

Answer 1

Based on your statement that I'm trying to get the If statement to search all of column A and copy all Cars that are year 1991 to sheet2, it seems like Autofilter might be an easier solution than looping. You should be able to use something like this:
Sub TestyTestTest()
Dim lastrowsheet1 As Long
Dim lastrowsheet2 As Long
With ThisWorkbook.Sheets("Sheet1")
.AutoFilterMode = False
lastrowsheet1 = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range(.Cells(1, 1), .Cells(lastrowsheet1, 4)).AutoFilter Field:=1, Criteria1:="1991"
.Range(.Cells(2, 1), .Cells(lastrowsheet1, 4)).SpecialCells(xlCellTypeVisible).Copy
.AutoFilterMode = False
End With
With ThisWorkbook.Sheets("Sheet2")
.AutoFilterMode = False
lastrowsheet2 = .Cells(.Rows.Count, 1).End(xlUp).Row
.Cells(lastrowsheet2 + 1, 1).PasteSpecial Paste:=xlPasteValues
.AutoFilterMode = False
End With
Application.CutCopyMode = False
End Sub
EDIT:
Trying to stick close to your original code, would something like this be more like what you are looking for?
Sub TakeTwo()
Dim a As Worksheet
Dim b As Worksheet
Dim c As Worksheet
Set a = ThisWorkbook.Sheets("Sheet1")
Set b = ThisWorkbook.Sheets("Sheet2")
Set c = ThisWorkbook.Sheets("Sheet3")
Dim i As Long
Dim lastrowsheet1 As Long
Dim erow As Long
lastrowsheet1 = a.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrowsheet1
If a.Cells(i, 1).Value = 1991 Then
erow = b.Cells(b.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
b.Cells(erow, 1) = a.Cells(i, 1)
b.Cells(erow, 2) = a.Cells(i, 2)
b.Cells(erow, 3) = a.Cells(i, 3)
b.Cells(erow, 4) = a.Cells(i, 4)
End If
Next i
Application.CutCopyMode = False
b.Columns.AutoFit
End Sub
SECOND EDIT - OP's NEW PROBLEM:
It looks like your data is just pasting over itself because erow is defined as the row after the last row in column 1 that is not empty, but you are not actually putting any data into that column, so erow isn't moving down to the next line.
Basically, change the column number in this line:
erow = b.Cells(b.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
The 1 in b.Cells(b.Rows.Count, 1) should be changed to a column number that you paste data into every time. Alternatively, you could use erow as a counter and increment it manually each time through the loop. In that case move the existing line that defines erow up underneath the line that defines lastrowsheet1 and then put erow = erow + 1 inside the loop after all the pasting has taken place but before End if. If you put it after End If, you'll end up with a bunch of blank lines between your data.