Question

我在Sheet1和sheet2的A，B，C，D和E列中都有值。此外，这些值是其他工作表中的一些vlookup值。现在，我应该如何编写代码以（仅）从 sheet1 和 sheet2 复制这些值并粘贴到上传工作表中。

注意： Sheet1 和 sheet2 ，

中的列值

** A **复制到上载的 D 中，
B 复制到上载的F列
C 要复制到上载的 C 列中，
D 复制到上载的 E 中

每次复制的库仑数都会不同。因此，当将sheet1复制到“上载”时，它必须找到下一个可用行，并开始将sheet2中的值对应到其中。

Private Sub CommandButton1_Click() Dim firstrowDB1 As Long, lastrow1 As 
Long Dim lastcol As Long, firstrowDB As Long Dim arr1, arr2, i, 
firstRowCount As Integer firstrowDB1 = 1
arr1 = Array("A", "B", "C", "D")
arr2 = Array("D", "F", "C", "E")
For i = LBound(arr1) To UBound(arr1)
    Sheets("Sheet1").Columns(arr1(i)).Copy

    Sheets("upload").Columns(arr2(i)).PasteSpecial xlPasteValues
Next
Application.CutCopyMode = False

上面的代码非常适合在特定的列中将sheet1复制到Upload，但是我不应该在extsheet中查找下一个空白单元格并开始复制和粘贴Sheet 2中的值。

请帮助！

Answer 1

这看起来很多，但是由于要切换各列，因此需要进行多次复制/粘贴。您也可以使彼此之间的距离相等并节省时间，但是我在这里没有做到这一点。

请注意，完成从Upload粘贴的值后，您需要重新计算Sheet 1的最后一行。除了重新计算LRow3，您还可以做一些数学运算。 LRow3的第二次计算也将等于LRow3 + LRow1-1的初始值。

切换屏幕更新以提高性能

Option Explicit

Sub Parsley()

Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")
Dim Upl As Worksheet: Set Upl = ThisWorkbook.Sheets("Upload")

Dim LRow1 As Long, LRow2 As Long, LRow3 As Long

LRow1 = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
LRow2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
LRow3 = Upl.Range("A" & Upl.Rows.Count).End(xlUp).Offset(1).Row

Application.ScreenUpdating = False
    ws1.Range("A2:A" & LRow1).Copy: Upl.Range("D" & LRow3).PasteSpecial xlPasteValues
    ws1.Range("B2:B" & LRow1).Copy: Upl.Range("F" & LRow3).PasteSpecial xlPasteValues
    ws1.Range("C2:C" & LRow1).Copy: Upl.Range("C" & LRow3).PasteSpecial xlPasteValues
    ws1.Range("D2:D" & LRow1).Copy: Upl.Range("E" & LRow3).PasteSpecial xlPasteValues

    LRow3 = Upl.Range("A" & Upl.Rows.Count).End(xlUp).Offset(1).Row

    ws2.Range("A2:A" & LRow2).Copy: Upl.Range("D" & LRow3).PasteSpecial xlPasteValues
    ws2.Range("B2:B" & LRow2).Copy: Upl.Range("F" & LRow3).PasteSpecial xlPasteValues
    ws2.Range("C2:C" & LRow2).Copy: Upl.Range("C" & LRow3).PasteSpecial xlPasteValues
    ws2.Range("D2:D" & LRow2).Copy: Upl.Range("E" & LRow3).PasteSpecial xlPasteValues
Application.ScreenUpdating = True

End Sub

Answer 2

我试图用你的方法刺伤。我在数组而不是字母中使用了列索引号
（{A = 1，B = 2，C = 3，等）

它更短，但是要复杂得多。这将始终使用Column A作为最后一行的位置指示符（从下至上，从上至下）。 未测试

Option Explicit

Sub Parsley()

Dim CopyArr: CopyArr = Array(1, 2, 3, 4)
Dim PasteArr: PasteArr = Array(4, 6, 3, 5)
Dim ws: ws = Array("Sheet1", "Sheet2")

Dim ws3 As Worksheet: Set ws3 = ThisWorkbook.Sheets("Upload")

Dim i As Integer, j As Integer, LRow As Long, uLRow As Long

Application.ScreenUpdating = False
    For i = LBound(ws) To UBound(ws)
        Set ws = Sheets(ws(i))
        LRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
        uLRow = ws3.Range("A" & ws3.Rows.Count).End(xlUp).Offset(1).Row
            For j = LBound(CopyArr) To UBound(CopyArr)
                ws.Range(ws.Cells(2, CopyArr(j)), ws.Cells(LRow, CopyArr(j))).Copy
                ws3.Cells(uLRow, PasteArr(j)).End(xlUp).Offset(1).PasteSpecial xlPasteValues
            Next j
    Next i
Application.ScreenUpdating = True

End Sub

从Sheet1和Sheet2复制值粘贴到上载工作表中

2 个答案: