Vba 为dynamic lastrow将数据从一个工作表复制到另一个工作表_Vba_Excel_For Loop

Vba 为dynamic lastrow将数据从一个工作表复制到另一个工作表

vba excel for-loop

Vba 为dynamic lastrow将数据从一个工作表复制到另一个工作表,vba,excel,for-loop,Vba,Excel,For Loop,我正在尝试将数据从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).R

我正在尝试将数据从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.A列的最后一行复制并粘贴到Sheet2.A列，而我需要它复制每一行直到最后一行。Sheet1的最后一行。A列是动态的，每周都会更改

感谢您的帮助！请记住，我是新的VBA，只有C++的经验，因此我似乎不能使逻辑工作。

谢谢你的帮助！：）

下面的代码将复制/粘贴从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

第1版

迭代2组列（iter 1:
```
ws1.A
```
至
```
ws2.A
```
，iter 2:
```
ws1.C
```
至
```
ws2.H
```
）
查找复制的每列的最后一行
将范围中的所有值复制到变量数组
- iter 1:
```
ws1.A
```
  （带数据的范围）到
```
ws2.A
```
  （空）
- iter 2:
```
ws1.C
```
  （包含数据的范围）到
```
ws2.H
```
  （空）
迭代ws1中的每个值（行），并将其复制到ws2数组中的同一“行”
将所有值从array2复制到ws2上的范围

第2版

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

谢谢你！很好用！！：）

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

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