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

Question

我在下面放置的代码是有效和无效的组合。

未注释的代码会将单元格从“ sheet1”复制到“ sheet2”。

我无法正常工作的是我已禁用的代码，该代码将替代我的范围方法，从“ sheet1”到“ sheet2”。

我的If Then Code也是我要完成的工作的一部分。 我正在尝试获取If语句来搜索所有A列，并将所有1991年的Cars复制到sheet2。

记住我的编码技巧很差，我正在尽力显示和解释，以便为您提供帮助。
这是床单1和2

（hxxp：//s15.postimg.org/orfw7tlaz/test.jpg）

旧代码

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

因此，我添加了一些行，并开始更改单元格位置以反映所需的格式，现在运行宏时，它仅将最后一行从Sheet1复制到sheet2。 我相信这与这些单元格的顺序有关。

        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)

改变这些背面可以修复它，因此它可以复制所有单元格，但不是我想要的。 我正在尝试运行的代码如下

新代码工作感谢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

现在使用相同的工作代码但不同的功能不起作用

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

因此，我添加了另一个带有Dim r的For循环，并添加了另一行erow = erow + r＆现在，代码将复制所需的前两行，但不再继续遍历列表。 这让我感到困惑。 这是我添加的以下代码。

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

基于您I'm trying to get the If statement to search all of column A and copy all Cars that are year 1991 to sheet2 ，看来Autofilter可能比循环更容易。 您应该可以使用以下内容：

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

编辑：

尝试贴近您的原始代码，这样的事情会更像您想要的东西吗？

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

第二次编辑-OP的新问题：

看来您的数据只是在粘贴自身，因为erow被定义为第1列中最后一行之后的行，该行不为空，但是您实际上没有将任何数据放入该列中，因此erow不会向下移动到下一行。

基本上，更改此行中的列号：

erow = b.Cells(b.Rows.Count, 1).End(xlUp).Offset(1, 0).Row

在1在b.Cells(b.Rows.Count, 1)应改为你的数据粘贴到每次一列数。 另外，您可以将erow用作计数器，并在每次循环时手动对其进行递增。 在这种情况下移动至现有行定义erow向上限定所述线下方lastrowsheet1然后把erow = erow + 1在循环内的所有粘贴已经发生之后，但在End if 。 如果将其放在End If ，则会在数据之间出现一堆空白行。