在Excel中復制多個單元格

Question

我對此並不陌生，但是我試圖復制一個Excel工作簿中的多個單元格並將它們粘貼到同一工作簿的單獨選項卡中。

上面是我的電子表格外觀的示例，但是我的電子表格中有800多行數據。

我需要復制名稱並將其放入Sheet2的A列，然后將帳號放入Sheet2的D列。

我嘗試了這2種不同的方式。

1. 使用以下代碼：

    Sheets("Sheet1").Select Range("A1,A3,A5,A7,A9").Select Range("A10").Activate Selection.Copy Sheets("Sheet2").Select Range("A1").Select ActiveSheet.Paste Sheets("Sheet1").Select Range("A2,A4,A6,A8,A10").Select Range("A10").Activate Selection.Copy Sheets("Sheet2").Select Range("D1").Select ActiveSheet.Paste 

   這給了我一個Compile Error Syntax Error 。

2. 代碼＃2

    Range("A2").Select Selection.Cut Range("D1").Select ActiveSheet.Paste Range("A4").Select Selection.Cut Range("D3").Select ActiveSheet.Paste ... 

   這是將它們保留在同一選項卡中，而不是將它們粘貼到單獨的選項卡中（我會在以后復制它們）。 我為每個客戶重復此操作。 這給了我一個范圍誤差，基本上說它太大了。 不幸的是，由於刪除了它，所以無法重新創建它。

有沒有人有一個更簡單的方式來執行此操作而不會導致錯誤？

Answer 1

假設您的數據持續交替（姓名，帳戶），請嘗試此操作。

Sub marine()
    Dim lr As Long, i As Long
    Dim sh1 As Worksheet, sh2 As Worksheet
    '/* declare the worksheets and use variables in the rest of the code */
    Set sh1 = Sheets("Sheet1"): Set sh2 = Sheets("Sheet2")

    With sh1
        lr = .Range("A" & .Rows.Count).End(xlUp).Row '/* get the last row in Sheet1 */
        For i = 1 To lr '/* loop to all rows identified */
            If i Mod 2 = 1 Then '/* check if odd or even, copy in A if odd */
                .Range("A" & i).Copy _
                sh2.Range("A" & sh2.Rows.Count).End(xlUp).Offset(1, 0)
            Else '/* copy in D otherwise */
                .Range("A" & i).Copy _
                sh2.Range("D" & sh2.Rows.Count).End(xlUp).Offset(1, 0)
            End If
        Next
    End With
End Sub

上面將數據從Sheet1復制到Sheet2，但將第一行留為空白。
此外，它始終將數據復制到Sheet2中每列的最后一行（A和D）。
因此，另一種方法是：

Sub ject()
    Dim lr As Long, i As Long, lr2 As Long
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim rNames As Range, rAcct As Range
    Set sh1 = Sheets("Sheet1"): Set sh2 = Sheets("Sheet2")

    With sh1
        lr = .Range("A" & .Rows.Count).End(xlUp).Row
        For i = 1 To lr
            If i Mod 2 = 1 Then
                If rNames Is Nothing Then '/* get all the cells with names */
                    Set rNames = .Range("A" & i)
                Else
                    Set rNames = Union(rNames, .Range("A" & i))
                End If
            Else
                If rAcct Is Nothing Then '/* get all the cells with accounts */
                    Set rAcct = .Range("A" & i)
                Else
                    Set rAcct = Union(rAcct, .Range("A" & i))
                End If
            End If
        Next
    End With

    With sh2
        '/* get the last filled Names column in Sheet2 */
        lr2 = .Range("A" & .Rows.Count).End(xlUp).Row
        rNames.Copy .Range("A" & lr2) '/* execute 1 time copy */
        rAcct.Copy .Range("D" & lr2) '/* execute 1 time copy */
    End With
End Sub

上面的代碼可確保正確的帳戶與正確的名稱相鄰。
而且由於執行了一（1）次復制，您也可能會獲得執行性能。 HTH。

PS盡可能避免使用Select 。

Answer 2

我實現的邏輯是循環直到Sheet2中Sheet1最后一行，循環變量始終表示名稱所在的行，下一行是帳號，因此在循環中將這些值分配給另一張工作表上的特定列很容易。 另外，我使用了另一個變量j ，它指示Sheet2連續行。

解：

Sub CopyData()

Dim sourceWs As Worksheet, targetWs As Worksheet, i As Long, lastRow As Long, j As Long
j = 1
Set sourceWs = Worksheets("Sheet1")
Set targetWs = Worksheets("Sheet2")
lastRow = sourceWs.Cells(sourceWs.Rows.Count, 1).End(xlUp).Row

For i = 1 To lastRow Step 2
    targetWs.Cells(j, 1) = sourceWs.Cells(i, 1)
    targetWs.Cells(j, 4) = sourceWs.Cells(i + 1, 1)
    j = j + 1
Next

End Sub