Question

我试图将Sheet1（A列和C列）中的数据复制到Sheet2（A列和H列）。

以下是我通过在线搜索整理的代码。

Dim ws1 As Worksheet
Dim ws2 As Worksheet

Set ws1 = Sheet1
Set ws2 = Sheet2
Const WS1_COL = "A"
Const WS2_COL = "A"

Dim lr, b, c, i As Long
lr = ws1.Cells(ws1.Rows.Count, WS1_COL).End(xlUp).Row

b = ws1.Range(WS1_COL & "3:" & WS1_COL & lr)

For i = 2 To lr - 1

    For c = 1 To lr - 1
        ws2.Range(WS2_COL & i & ":" & WS2_COL & i + 1).Value2 = b(c, 1)
    c = c + 1
    Next c

Next i

代码中没有错误 - 但它只是将Sheet1.Column A的最后一行复制并粘贴到Sheet2.Column A，而我需要它将每行复制到最后一行。 Sheet1.Column A的lastrow是动态的，每周都会更改。

任何帮助表示赞赏！请记住，我是VBA的新手并且只有C ++的经验，因此我似乎无法使逻辑工作。

感谢您的帮助！：）

Answer 1

版本1

通过两组列进行迭代（iter 1：ws1.A至ws2.A，iter 2：ws1.C至ws2.H）
查找复制的每列的最后一行
将Range中的所有值复制到变量数组
- iter 1：ws1.A（数据范围）到ws2.A（空）
- iter 2：ws1.C（数据范围）到ws2.H（空）
迭代ws1中的每个值（行）并将其复制到ws2的数组中的“row”
将所有值从array2复制到ws2上的Range

Option Explicit

Public Sub CopyColumns1()
    Const WS1_COLS = "A C"  'Columns to copy from
    Const WS2_COLS = "A H"  'Columns to copy to

    Dim ws1 As Worksheet:   Set ws1 = Sheet1
    Dim ws2 As Worksheet:   Set ws2 = Sheet2

    Dim cols1 As Variant:   cols1 = Split(WS1_COLS)     'Variant Array("A", "C")
    Dim cols2 As Variant:   cols2 = Split(WS2_COLS)     'Variant Array("A", "H")

    Dim c As Long, maxRows As Long, r As Long
    Dim lr1 As Long, arr1 As Variant, arr2 As Variant

    maxRows = ws1.Rows.Count    'Last Excel row (not to extract it multiple times)

    For c = LBound(cols1) To UBound(cols1)  'Iterate all columns in ws1 (synced with ws2)
        lr1 = ws1.Cells(maxRows, cols1(c)).End(xlUp).Row    'cols1 = Array("A", "C")

        'copy ranges to arrays, for speed
        arr1 = ws1.Range(ws1.Cells(2, cols1(c)), ws1.Cells(lr1, cols1(c))).Formula
        arr2 = ws2.Range(ws2.Cells(2, cols2(c)), ws2.Cells(lr1, cols2(c))).Formula

        For r = LBound(arr1) To UBound(arr1)    'Iterate all rows in ws1
            arr2(r, 1) = arr1(r, 1)             'Copy ws1.A to ws2.A, then ws1.C to ws2.H
        Next r  'row

        'moves the array to the range on ws2 (similar to paste, without cell formatting
        ws2.Range(ws2.Cells(2, cols2(c)), ws2.Cells(lr1, cols2(c))).Formula = arr2
    Next c      'column (iter 1: A to A, iter 2: C to H)
End Sub

版本2

查找ws1上所有列的最后一行（基于UsedRange）
将UsedRange偏移1行，以排除标题（调整-1行）
通过两组列进行迭代（iter 1：ws1.A至ws2.A，iter 2：ws1.C至ws2.H）
在一次操作中复制整列，以及单元格格式

Option Explicit

Public Sub CopyColumns2()
    Const WS1_COLS = "A C"  'Columns to copy from
    Const WS2_COLS = "A H"  'Columns to copy to

    Dim ws1 As Worksheet:   Set ws1 = Sheet1
    Dim ws2 As Worksheet:   Set ws2 = Sheet2

    Dim cols1 As Variant:   cols1 = Split(WS1_COLS)     'Variant Array("A", "C")
    Dim cols2 As Variant:   cols2 = Split(WS2_COLS)     'Variant Array("A", "H")

    Dim c As Long, r As Long, lr1 As Long, ur1 As Range

    lr1 = ws1.UsedRange.Rows.Count
    Set ur1 = ws1.UsedRange.Offset(1).Resize(lr1 - 1)   '1 row lower, to exclude header

    For c = LBound(cols1) To UBound(cols1)  'Iterate all columns in ws1 (synced with ws2)
       ur1.Columns(cols1(c)).Copy ws2.Cells(2, cols2(c))   'Copy paste (with cell formats)
    Next c
End Sub

Answer 2

下面的代码将从sheet1列A到sheet2列A和sheet1列C到sheet2列H的所有内容进行复制/粘贴，不包括标题。

Sub copy_test()

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet

    Set ws1 = Sheet1
    Set ws2 = Sheet2

    Ws1.range("A2",Ws1.range("A999999").end(xlup)).copy Ws2.range("A2")
    Ws1.range("C2",Ws1.range("C999999").end(xlup)).copy Ws2.range("H2")

End sub

或仅限值：

Sub copy_test2()

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet

    Set ws1 = Sheet1
    Set ws2 = Sheet2

    ws2.Range("A2:A" & ws1.Range("A999999").End(xlUp).Row).Value = ws1.Range("A2", ws1.Range("A999999").End(xlUp)).Value
    ws2.Range("H2:H" & ws1.Range("C999999").End(xlUp).Row).Value = ws1.Range("C2", ws1.Range("C999999").End(xlUp)).Value

End Sub

将数据从一个工作表复制到另一个工作表以进行动态lastrow

2 个答案: