Question

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

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

Answer 1

我没有运行您的代码，但是除非丢失某些内容，否则您的Do循环将不会执行，或者会导致无限循环（因为您似乎没有更改{{1}的值） }和xcol）。

在循环内，您似乎重复粘贴到相同的范围（xrow）－这意味着每次迭代都将覆盖前一次迭代的结果。好像您只是在测试（以查看循环是否工作），然后要更改粘贴的范围。

如果我正确理解：

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

也许下面的代码可以使您了解如何实现所需的目标：

由于您没有在代码中为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并提供适当的参数。

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

1 个答案: