Question

我下面的代码是有效的和无法工作的组合。

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

我无法正常工作的是我已禁用的代码，它会将我的范围处理方法从“sheet1”替换为“sheet2”。

我的If Then代码也是我要完成的事情。我试图让If语句搜索所有A列并将所有1991年的汽车复制到sheet2。

请注意我糟糕的编码技巧我正在尽力表现出来解释所以我可以得到帮助这是Sheets 1＆amp; 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)

更改这些背面修复它所以它复制所有细胞，但它不是我想要做的。我试图运行的代码是

NEW CODE工作感谢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循环并添加了另一个Line erow = erow + r＆amp;现在代码复制了所需的前两行，但没有继续迭代列表。这让我很困惑。这是我添加的代码。

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列中最后一行之后非空的行，但您实际上并未将任何数据放入该列，因此{ {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之后，那么您的数据之间会出现一堆空白行。

VBA Excel自动复制＆amp;根据IF语句粘贴特定单元格

1 个答案: