时间戳

首页 > 解决方案 > 在两个工作簿之间复制和粘贴动态范围

excel - 在两个工作簿之间复制和粘贴动态范围

问题描述

我正在尝试将在一个工作簿中找到的数据复制并粘贴到另一个工作簿。我在复制数据时遇到困难，我不太确定是否是循环遍历行数据，这导致了问题：

Sub essaie()

    Dim x As Workbook
    Dim y As Workbook
    Dim xlastcol As Integer 'variable for the last row
    Dim xcol As Variant 'variable first row
    Dim Headers() As Variant
    Dim h As Variant
    Dim ws As Worksheet
    Dim xrow As Integer
    Dim xlastrow As Variant

    Set y = Workbooks("VBAGOOD.xlsx")
    Set x = Workbooks("Aubaine.xlsm")

    Headers() = Array("net", "date", "description")

    y.Worksheets("try").Activate

    Set ws = y.Worksheets("try")

    xcol = 1 
    xlastcol = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column

    xrow = 2
    xlastrow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    Do Until xcol = xlastcol 'loop through a range of data
    Do Until xrow = xlastrow

        For Each h In Headers
            If h = ws.Cells(xcol, xlastcol).Value Then
                ws.Activate
                ws.Cells(xrow, xlastrow).Select
                Selection.Copy
                x.Activate
                x.Worksheets("test").Range("a1:a65").PasteSpecial
           End If  
        Next h

    Loop
    Loop

End Sub

我要复制的数据低于三列。

date      address     comments 

123       udhsdh      gguu

124       udhsdh      gguu

125       udhsdh      sdg

标签： excelvba

解决方案

我没有运行你的代码，但除非我遗漏了什么，否则你的Do循环要么不执行，要么导致无限循环（因为你似乎没有改变各个循环的值xcol和xrow内部的值）。

在循环内部，您似乎A1:A65重复粘贴到同一范围 ( ) - 这意味着每次迭代都会覆盖前一次迭代的结果。好像您只是在测试（以查看循环是否有效），然后将更改您粘贴的范围。

如果我理解正确：

  • 从工作表 A 复制“数据”并粘贴到工作表 B
  • 工作表 A 和工作表 B 在不同的工作簿中
  • 只复制带有标题的列：net，，date（description尽管您的问题是：date，，，address）comments
  • 可以使用 column 检测最后一行A（根据您的代码）。

也许下面的代码可以让您了解如何实现您想要的：

Option Explicit

Private Function GetHeaderColumnIndexes(ByVal someSheet As Worksheet, ParamArray headersToSearchFor() As Variant) As Long()
    Const HEADER_ROW_INDEX As Long = 1 ' I assume row 1, change as neccessary.

    Dim outputArray() As Long
    ReDim outputArray(LBound(headersToSearchFor) To UBound(headersToSearchFor))

    Dim i As Long
    Dim matchResult As Variant
    For i = LBound(headersToSearchFor) To UBound(headersToSearchFor)
        matchResult = Application.Match(headersToSearchFor(i), someSheet.Rows(HEADER_ROW_INDEX), 0)

        Debug.Assert IsNumeric(matchResult) ' Should probably raise an error instead.
        outputArray(i) = matchResult
    Next i
    GetHeaderColumnIndexes = outputArray
End Function

Private Sub TransferDataAcrossWorkbooks()

    Dim sourceSheet As Worksheet
    Set sourceSheet = Workbooks("VBAGOOD.xlsx").Worksheets("try") ' Change as necessary

    Dim lastSourceRow As Long
    lastSourceRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row

    Dim destinationSheet As Worksheet
    Set destinationSheet = Workbooks("Aubaine.xlsm").Worksheets("test") ' Change as necessary

    Dim targetColumnIndexes() As Long
    targetColumnIndexes = GetHeaderColumnIndexes(sourceSheet, "net", "date", "description")

    Dim columnIndex As Variant
    For Each columnIndex In targetColumnIndexes ' Would be better to use For loop instead of For each
        Dim rangeToCopy As Range
        Set rangeToCopy = Intersect(sourceSheet.Range("1:" & lastSourceRow), sourceSheet.Columns(columnIndex))

        Dim destinationColumnIndex As Long
        destinationColumnIndex = destinationColumnIndex + 1

        Dim rangeToPasteTo As Range
        Set rangeToPasteTo = destinationSheet.Cells(1, destinationColumnIndex)

        rangeToCopy.Copy rangeToPasteTo
    Next columnIndex

End Sub
  • 由于您没有Range.PasteSpecial在代码中提供任何参数，因此使用了默认值，我认为这相当于常规粘贴。
  • 如果您想更改此行为（例如仅粘贴值），您可以重新引入Range.PasteSpecial并提供适当的参数。

推荐阅读