VBA Excel基于IF语句自动复制和粘贴特定单元格

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.